You are given a rooted tree consisting of $$$n$$$ vertices. Vertices are numbered from $$$1$$$ to $$$n$$$. Any vertex can be the root of a tree.A tree is a connected undirected graph without cycles. A rooted tree is a tree with a selected vertex, which is called the root.The tree is specified by an array of ancestors $$$b$$$ containing $$$n$$$ numbers: $$$b_i$$$ is an ancestor of the vertex with the number $$$i$$$. The ancestor of a vertex $$$u$$$ is a vertex that is the next vertex on a simple path from $$$u$$$ to the root. For example, on the simple path from $$$5$$$ to $$$3$$$ (the root), the next vertex would be $$$1$$$, so the ancestor of $$$5$$$ is $$$1$$$.The root has no ancestor, so for it, the value of $$$b_i$$$ is $$$i$$$ (the root is the only vertex for which $$$b_i=i$$$).For example, if $$$n=5$$$ and $$$b=[3, 1, 3, 3, 1]$$$, then the tree looks like this.    An example of a rooted tree for $$$n=5$$$, the root of the tree is a vertex number $$$3$$$. You are given an array $$$p$$$ — a permutation of the vertices of the tree. If it is possible, assign any positive integer weights on the edges, so that the vertices sorted by distance from the root would form the given permutation $$$p$$$.In other words, for a given permutation of vertices $$$p$$$, it is necessary to choose such edge weights so that the condition $$$dist[p_i]<dist[p_{i+1}]$$$ is true for each $$$i$$$ from $$$1$$$ to $$$n-1$$$. $$$dist[u]$$$ is a sum of the weights of the edges on the path from the root to $$$u$$$. In particular, $$$dist[u]=0$$$ if the vertex $$$u$$$ is the root of the tree.For example, assume that $$$p=[3, 1, 2, 5, 4]$$$. In this case, the following edge weights satisfy this permutation:  the edge ($$$3, 4$$$) has a weight of $$$102$$$;  the edge ($$$3, 1$$$) has weight of $$$1$$$;  the edge ($$$1, 2$$$) has a weight of $$$10$$$;  the edge ($$$1, 5$$$) has a weight of $$$100$$$. The array of distances from the root looks like: $$$dist=[1,11,0,102,101]$$$. The vertices sorted by increasing the distance from the root form the given permutation $$$p$$$.Print the required edge weights or determine that there is no suitable way to assign weights. If there are several solutions, then print any of them.

The first line of input data contains an integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of input data sets in the test. Each test case consists of three lines. The first of them contains an integer $$$n$$$ ($$$1 \le n \le 2 \cdot 10^5$$$). It is the number of vertices in the tree. The second line contains $$$n$$$ integers $$$b_1, b_2, \dots, b_n$$$ ($$$1 \le b_i \le n$$$). It is guaranteed that the $$$b$$$ array encodes some rooted tree. The third line contains the given permutation $$$p$$$: $$$n$$$ of different integers $$$p_1, p_2, \dots, p_n$$$ ($$$1 \le p_i \le n$$$). It is guaranteed that the sum of the values $$$n$$$ over all test cases in the test does not exceed $$$2 \cdot 10^5$$$.

For each set of input data print the answer on a separate line. If the solution exists, print an array of $$$n$$$ integers $$$w_1, w_2, \dots, w_n$$$, where $$$w_i$$$ is the weight of the edge that leads from $$$b_i$$$ to $$$i$$$. For the root there is no such edge, so use the value $$$w_i=0$$$. For all other vertices, the values of $$$w_i$$$ must satisfy the inequality $$$1 \le w_i \le 10^9$$$. There can be equal numbers among $$$w_i$$$ values, but all sums of weights of edges from the root to vertices must be different and satisfy the given permutation. If there are several solutions, output any of them. If no solution exists, output -1.

NoteThe first set of input data of the example is analyzed in the main part of the statement.In the second set of input data of the example, it is impossible to assign the positive weights to obtain a given permutation of vertices.

{-# LANGUAGE ParallelListComp, TypeApplications #-}

import Control.Monad

-- import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as BS
import Data.Time.Clock.POSIX
import Data.Map.Strict ((!))
import qualified Data.Map.Strict as Map

-- import Data.HashSet
import Data.Maybe

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

readInt :: IO Int
readInt = readLn @Int

-- type Arr = UArray Int Int
-- fixBuf b = hSetBuffering b (BlockBuffering Nothing)
main = do
  numCases <- readInt
  replicateM_ numCases $ do
    len <- readInt
    rootList <- readInts
    order <- readInts
    let rootMap
          -- array @UArray (1, len)
         = Map.fromList [(i, r) | i <- [1 .. len] | r <- rootList]
        orderMap
          -- array @UArray (1, len)
         = Map.fromList [(x, i) | x <- order | i <- [0 .. len]]
    -- print (rootMap, orderMap)
    putStrLn $
      if all (\k -> orderMap ! k >= orderMap ! (rootMap ! k)) order
        then ([1 .. len] >>= \k ->
                show (orderMap ! k - orderMap ! (rootMap ! k)) ++ " ")
        else "-1"

{-# LANGUAGE ParallelListComp, TypeApplications #-}

import Control.Monad

-- import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as BS

import Data.Map.Strict ((!))
import qualified Data.Map.Strict as Map

-- import Data.HashSet
import Data.Maybe

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

readInt :: IO Int
readInt = readLn @Int

-- type Arr = UArray Int Int
-- fixBuf b = hSetBuffering b (BlockBuffering Nothing)
main = do
  numCases <- readInt
  replicateM_ numCases $ do
    len <- readInt
    rootList <- readInts
    order <- readInts
    let rootMap
          -- array @UArray (1, len)
         = Map.fromList [(i, r) | i <- [1 .. len] | r <- rootList]
        orderMap
          -- array @UArray (1, len)
         = Map.fromList [(x, i) | x <- order | i <- [0 .. len]]
    -- print (rootMap, orderMap)
    putStrLn $
      if all (\k -> orderMap ! k >= orderMap ! (rootMap ! k)) order
        then ([1 .. len] >>= \k ->
                show (orderMap ! k - orderMap ! (rootMap ! k)) ++ " ")
        else "-1"

{-# LANGUAGE ParallelListComp, TypeApplications #-}

import Control.Monad

-- import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as BS

import Data.Map ((!))
import qualified Data.Map as Map

-- import Data.HashSet
import Data.Maybe

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

readInt :: IO Int
readInt = readLn @Int

-- type Arr = UArray Int Int
-- fixBuf b = hSetBuffering b (BlockBuffering Nothing)
main = do
  numCases <- readInt
  replicateM_ numCases $ do
    len <- readInt
    rootList <- readInts
    order <- readInts
    let rootMap
          -- array @UArray (1, len)
         = Map.fromList [(i, r) | i <- [1 .. len] | r <- rootList]
        orderMap
          -- array @UArray (1, len)
         = Map.fromList [(x, i) | x <- order | i <- [0 .. len]]
    -- print (rootMap, orderMap)
    putStrLn $
      if all (\k -> orderMap ! k >= orderMap ! (rootMap ! k)) order
        then ([1 .. len] >>= \k ->
                show (orderMap ! k - orderMap ! (rootMap ! k)) ++ " ")
        else "-1"

{-# LANGUAGE ParallelListComp, TypeApplications #-}

import Control.Monad
import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as BS
import Data.Maybe

import System.IO

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

readInt :: IO Int
readInt = readLn @Int

type Arr = UArray Int Int

fixBuf b = hSetBuffering b (BlockBuffering Nothing)

-- import Data.Map ((!))
-- not a change lol 23
main = do
  numCases <- readInt
  replicateM_ numCases $ do
    len <- readInt
    rootList <- readInts
    order <- readInts
    let rootMap =
          array @UArray (1, len) [(i, r) | i <- [1 .. len] | r <- rootList]
        orderMap =
          array @UArray (1, len) [(x, i) | x <- order | i <- [0 .. len]]
    -- print (rootMap, orderMap)
    putStrLn $
      if all (\k -> orderMap ! k >= orderMap ! (rootMap ! k)) order
        then ([1 .. len] >>= \k ->
                show (orderMap ! k - orderMap ! (rootMap ! k)) ++ " ")
        else "-1"

{-# LANGUAGE ParallelListComp, TypeApplications #-}
{-# OPTIONS_GHC -O2 #-}

import Control.Monad
import Data.Array.Unboxed

-- import GHC.Arr
import System.IO

type Arr = UArray Int Int

fixBuf b = hSetBuffering b (BlockBuffering Nothing)

-- import Data.Map ((!))
-- not a change lol 23
main = do
  fixBuf stdin
  fixBuf stdout
  numCases <- readLn @Int
  replicateM_ numCases $ do
    len <- readLn @Int
    rootList <- fmap (read @Int) . words <$> getLine
    let rootMap =
          array @UArray (1, len) [(i, r) | i <- [1 .. len] | r <- rootList]
    order <- fmap (read @Int) . words <$> getLine
    let orderMap =
          array @UArray (1, len) [(x, i) | x <- order | i <- [0 .. len]]
    -- print (rootMap, orderMap)
    putStrLn $
      if all (\k -> orderMap ! k >= orderMap ! (rootMap ! k)) order
        then ([1 .. len] >>= \k ->
                show (orderMap ! k - orderMap ! (rootMap ! k)) ++ " ")
        else "-1"
  hFlush stdout

{-# LANGUAGE ParallelListComp, TypeApplications #-}

import Control.Monad
import Data.Array.Unboxed

-- import GHC.Arr
import System.IO

type Arr = UArray Int Int

fixBuf b = hSetBuffering b (BlockBuffering Nothing)

-- import Data.Map ((!))
-- not a change lol 23
main = do
  fixBuf stdin
  fixBuf stdout
  numCases <- readLn @Int
  replicateM_ numCases $ do
    len <- readLn @Int
    rootList <- fmap (read @Int) . words <$> getLine
    let rootMap =
          array @UArray (1, len) [(i, r) | i <- [1 .. len] | r <- rootList]
    order <- fmap (read @Int) . words <$> getLine
    let orderMap =
          array @UArray (1, len) [(x, i) | x <- order | i <- [0 .. len]]
    -- print (rootMap, orderMap)
    putStrLn $
      if all (\k -> orderMap ! k >= orderMap ! (rootMap ! k)) order
        then ([1 .. len] >>= \k ->
                show (orderMap ! k - orderMap ! (rootMap ! k)) ++ " ")
        else "-1"
  hFlush stdout

{-# LANGUAGE ParallelListComp, TypeApplications #-}

import Control.Monad
import Data.Array.Unboxed

-- import GHC.Arr
import System.IO

type Arr = UArray Int Int

fixBuf b = hSetBuffering b (BlockBuffering Nothing)

-- import Data.Map ((!))
-- not a change lol
main = do
  fixBuf stdin
  fixBuf stdout
  numCases <- readLn @Int
  replicateM_ numCases $ do
    len <- readLn @Int
    rootList <- fmap (read @Int) . words <$> getLine
    let rootMap =
          array @UArray (1, len) [(i, r) | i <- [1 .. len] | r <- rootList]
    order <- fmap (read @Int) . words <$> getLine
    let orderMap =
          array @UArray (1, len) [(x, i) | x <- order | i <- [0 .. len]]
    -- print (rootMap, orderMap)
    putStrLn $
      if all (\k -> orderMap ! k >= orderMap ! (rootMap ! k)) order
        then ([1 .. len] >>= \k ->
                show (orderMap ! k - orderMap ! (rootMap ! k)) ++ " ")
        else "-1"
  hFlush stdout

{-# LANGUAGE ParallelListComp, TypeApplications #-}

import Control.Monad
import Data.Array.Unboxed

-- import GHC.Arr
import System.IO

type Arr = UArray Int Int

fixBuf b = hSetBuffering b (BlockBuffering (Just 65536))

-- import Data.Map ((!))
-- not a change lol
main
  -- fixBuf stdin
  -- fixBuf stdout
 = do
  numCases <- readLn @Int
  replicateM_ numCases $ do
    len <- readLn @Int
    rootList <- fmap (read @Int) . words <$> getLine
    let rootMap =
          array @UArray (1, len) [(i, r) | i <- [1 .. len] | r <- rootList]
    order <- fmap (read @Int) . words <$> getLine
    let orderMap =
          array @UArray (1, len) [(x, i) | x <- order | i <- [0 .. len]]
    -- print (rootMap, orderMap)
    putStrLn $
      if all (\k -> orderMap ! k >= orderMap ! (rootMap ! k)) order
        then ([1 .. len] >>= \k ->
                show (orderMap ! k - orderMap ! (rootMap ! k)) ++ " ")
        else "-1"
  -- hFlush stdout

{-# LANGUAGE ParallelListComp, TypeApplications #-}

import Control.Monad
import Data.Array.Unboxed

-- import GHC.Arr
import System.IO

type Arr = UArray Int Int

fixBuf b = hSetBuffering b (BlockBuffering (Just 65536))

-- import Data.Map ((!))
-- not a change lol
main = do
  fixBuf stdin
  fixBuf stdout
  numCases <- readLn @Int
  replicateM_ numCases $ do
    len <- readLn @Int
    rootList <- fmap (read @Int) . words <$> getLine
    let rootMap =
          array @UArray (1, len) [(i, r) | i <- [1 .. len] | r <- rootList]
    order <- fmap (read @Int) . words <$> getLine
    let orderMap =
          array @UArray (1, len) [(x, i) | x <- order | i <- [0 .. len]]
    -- print (rootMap, orderMap)
    putStrLn $
      if all (\k -> orderMap ! k >= orderMap ! (rootMap ! k)) order
        then ([1 .. len] >>= \k ->
                show (orderMap ! k - orderMap ! (rootMap ! k)) ++ " ")
        else "-1"
  hFlush stdout

{-# LANGUAGE ParallelListComp, TypeApplications #-}

import Control.Monad
import GHC.Arr
import System.IO

fixBuf b = hSetBuffering b (BlockBuffering (Just 65536))

-- import Data.Map ((!))
-- not a change lol
main = do
  fixBuf stdin
  fixBuf stdout
  numCases <- readLn @Int
  replicateM_ numCases $ do
    len <- readLn @Int
    rootList <- fmap (read @Int) . words <$> getLine
    let rootMap = array (1, len) [(i, r) | i <- [1 .. len] | r <- rootList]
    order <- fmap (read @Int) . words <$> getLine
    let orderMap = array (1, len) [(x, i) | x <- order | i <- [0 .. len]]
    -- print (rootMap, orderMap)
    putStrLn $
      if all (\k -> orderMap ! k >= orderMap ! (rootMap ! k)) order
        then ([1 .. len] >>= \k ->
                show (orderMap ! k - orderMap ! (rootMap ! k)) ++ " ")
        else "-1"
  hFlush stdout

{-# LANGUAGE ParallelListComp, TypeApplications #-}

import Control.Monad
import GHC.Arr

-- import Data.Map ((!))
main = do
  numCases <- readLn @Int
  replicateM_ numCases $ do
    len <- readLn @Int
    rootList <- fmap (read @Int) . words <$> getLine
    let rootMap = array (1, len) [(i, r) | i <- [1 .. len] | r <- rootList]
    order <- fmap (read @Int) . words <$> getLine
    let orderMap = array (1, len) [(x, i) | x <- order | i <- [0 .. len]]
    -- print (rootMap, orderMap)
    putStrLn $
      if all (\k -> orderMap ! k >= orderMap ! (rootMap ! k)) order
        then ([1 .. len] >>= \k ->
                show (orderMap ! k - orderMap ! (rootMap ! k)) ++ " ")
        else "-1"

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Char8 as String
import qualified Data.ByteString.Builder.Prim as Prim
import Data.ByteString.Builder
import Control.Monad
import Control.Monad.ST
--import Control.Monad.Trans.State
import Data.Array.Base
import Data.Array.IO
import Data.Array.ST
import Data.Array.Unboxed
import Data.Array.MArray as Vector
import Data.Bits
import Data.Bool
import Data.Char
import Data.Graph
import Data.Int
import Data.List
import Data.Maybe
import Data.Ord
import Data.Ratio
import Data.Tuple
import Data.Function
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import System.IO
import System.IO.Unsafe
import System.Exit

import Data.IORef
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Fail
import Control.Applicative
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.IO.Class (liftIO)
import Data.Foldable (msum)
import Data.Char (isNumber, isPunctuation)

import Control.Monad.Identity (Identity(..))

printLog :: Show a => a -> a
printLog a = unsafePerformIO $ do putStrLn $ "{отладка[ "++show a ++ " ]отладка}"
                                  pure a

fArray :: Ix i => (i, i) -> (i -> a) -> Array i a
fArray b f = array b [(i, f i) | i <- range b]

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

type WEdge w = (Vertex, (w, Vertex))
type WGraph w = Array Vertex [(w, Vertex)]
data WTree w a = WNode { rootLabelW :: a
                       , subForestW :: [(w, WTree w a)]
                       } deriving Show

buildWG :: Bounds -> [WEdge w] -> WGraph w
buildWG = accumArray (flip (:)) []

dfsWTree :: WGraph w -> Vertex -> WTree w Vertex
dfsWTree g u = go u u where
    go p u = WNode u [(w, go u v) | (w, v) <- g!u, v /= p]

instance Functor (WTree w) where
    fmap f = go where
        go (WNode a ts) = WNode (f a) [(w, go t) | (w, t) <- ts]

getVertexOrder :: Bounds -> [Int] -> UArray Int Int
getVertexOrder bnds p = runSTUArray $ do
  arr <- newArray bnds 0
  forM_ (zip [0..(snd bnds - 1)] p) $ \(i, el) -> do
    writeArray arr el i
  return arr

getEdges' :: forall s. Int -> Bounds -> WTree Int Vertex -> ST s (STUArray s Int Int)
getEdges' root bnds tree = do
  edges <- (newArray bnds 0) :: ST s (STUArray s Int Int)

  let dfs :: Int -> Int -> WTree Int Vertex -> ST s ()
      dfs ww w (WNode v ts) = do
        writeArray edges v (w - ww)
        mapM_ (\(w', subts) -> dfs w w' subts) ts
  dfs 0 0 tree

  return edges

getEdges :: Int -> Bounds -> WTree Int Vertex -> UArray Int Int
getEdges root bnds tree = runSTUArray $ getEdges' root bnds tree

dfsCheckBad :: WTree Int Vertex -> Bool
dfsCheckBad (WNode v ts) = foldr (\(w,all@(WNode u ts')) suf -> suf || v > u || dfsCheckBad all) False ts

printlist = putStrLn . unwords . map show . elems

fita :: IO ()
fita = do
  [n] <- readInts
  mas <- readInts
  p <- readInts

  let vertexOrder = getVertexOrder (1,n) p
      g = buildWG (1,n) $ zipWith (\a b -> (b, (vertexOrder!a,a))) [1..n] mas
      root = fst . fromJust $ (find (\(a,b)->a==b) $ zip [1..n] mas)
      tree = dfsWTree g root

  if (dfsCheckBad ((vertexOrder!) <$> tree))
    then print (-1)
  else
    printlist $ getEdges root (1,n) tree

main :: IO ()
main = flip replicateM_ fita =<< readLn

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Char8 as String
import qualified Data.ByteString.Builder.Prim as Prim
import Data.ByteString.Builder
import Control.Monad
import Control.Monad.ST
--import Control.Monad.Trans.State
import Data.Array.Base
import Data.Array.IO
import Data.Array.ST
import Data.Array.Unboxed
import Data.Array.MArray as Vector
import Data.Bits
import Data.Bool
import Data.Char
import Data.Graph
import Data.Int
import Data.List
import Data.Maybe
import Data.Ord
import Data.Ratio
import Data.Tuple
import Data.Function
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import System.IO
import System.IO.Unsafe
import System.Exit

import Data.IORef
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Fail
import Control.Applicative
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.IO.Class (liftIO)
import Data.Foldable (msum)
import Data.Char (isNumber, isPunctuation)

import Control.Monad.Identity (Identity(..))

printLog :: Show a => a -> a
printLog a = unsafePerformIO $ do putStrLn $ "{отладка[ "++show a ++ " ]отладка}"
                                  pure a

fArray :: Ix i => (i, i) -> (i -> a) -> Array i a
fArray b f = array b [(i, f i) | i <- range b]

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

type WEdge w = (Vertex, (w, Vertex))
type WGraph w = Array Vertex [(w, Vertex)]
data WTree w a = WNode { rootLabelW :: a
                       , subForestW :: [(w, WTree w a)]
                       } deriving Show

buildWG :: Bounds -> [WEdge w] -> WGraph w
buildWG = accumArray (flip (:)) []

dfsWTree :: WGraph w -> Vertex -> WTree w Vertex
dfsWTree g u = go u u where
    go p u = WNode u [(w, go u v) | (w, v) <- g!u, v /= p]

instance Functor (WTree w) where
    fmap f = go where
        go (WNode a ts) = WNode (f a) [(w, go t) | (w, t) <- ts]

getVertexOrder :: Bounds -> [Int] -> UArray Int Int
getVertexOrder bnds p = runSTUArray $ do
  arr <- newArray bnds 0
  forM_ (zip [0..(snd bnds - 1)] p) $ \(i, el) -> do
    writeArray arr el i
  return arr

getEdges' :: forall s. Int -> Bounds -> WTree Int Vertex -> ST s (STUArray s Int Int)
getEdges' root bnds tree = do
  edges <- (newArray bnds 0) :: ST s (STUArray s Int Int)

  let dfs :: Int -> Int -> WTree Int Vertex -> ST s ()
      dfs p w (WNode v ts) = do
        get_ <- readArray edges p
        writeArray edges v (w - get_)
        mapM_ (\(w, subts) -> dfs v w subts) ts
  dfs root 0 tree

  return edges

getEdges :: Int -> Bounds -> WTree Int Vertex -> UArray Int Int
getEdges root bnds tree = runSTUArray $ getEdges' root bnds tree

dfsCheckBad :: WTree Int Vertex -> Bool
dfsCheckBad (WNode v ts) = foldr (\(w,all@(WNode u ts')) suf -> suf || v > u || dfsCheckBad all) False ts

printlist xs = putStrLn s
  where (' ':s) = foldl (\pref el -> pref++" "++(show el)) "" xs

fita :: IO ()
fita = do
  [n] <- readInts
  mas <- readInts
  p <- readInts

  let vertexOrder = getVertexOrder (1,n) p
      g = buildWG (1,n) $ zipWith (\a b -> (b, (vertexOrder!a,a))) [1..n] mas
      root = fst . fromJust $ (find (\(a,b)->a==b) $ zip [1..n] mas)
      tree = dfsWTree g root

  if (dfsCheckBad ((vertexOrder!) <$> tree))
    then print (-1)
  else
    printlist . elems $ getEdges root (1,n) tree

main :: IO ()
main = flip replicateM_ fita =<< readLn

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Char8 as String
import qualified Data.ByteString.Builder.Prim as Prim
import Data.ByteString.Builder
import Control.Monad
import Control.Monad.ST
--import Control.Monad.Trans.State
import Data.Array.Base
import Data.Array.IO
import Data.Array.ST
import Data.Array.Unboxed
import Data.Array.MArray as Vector
import Data.Bits
import Data.Bool
import Data.Char
import Data.Graph
import Data.Int
import Data.List
import Data.Maybe
import Data.Ord
import Data.Ratio
import Data.Tuple
import Data.Function
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import System.IO
import System.IO.Unsafe
import System.Exit

import Data.IORef
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Fail
import Control.Applicative
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.IO.Class (liftIO)
import Data.Foldable (msum)
import Data.Char (isNumber, isPunctuation)

import Control.Monad.Identity (Identity(..))

printLog :: Show a => a -> a
printLog a = unsafePerformIO $ do putStrLn $ "{отладка[ "++show a ++ " ]отладка}"
                                  pure a

fArray :: Ix i => (i, i) -> (i -> a) -> Array i a
fArray b f = array b [(i, f i) | i <- range b]

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

type WEdge w = (Vertex, (w, Vertex))
type WGraph w = Array Vertex [(w, Vertex)]
data WTree w a = WNode { rootLabelW :: a
                       , subForestW :: [(w, WTree w a)]
                       } deriving Show

buildWG :: Bounds -> [WEdge w] -> WGraph w
buildWG = accumArray (flip (:)) []

dfsWTree :: WGraph w -> Vertex -> WTree w Vertex
dfsWTree g u = go u u where
    go p u = WNode u [(w, go u v) | (w, v) <- g!u, v /= p]

instance Functor (WTree w) where
    fmap f = go where
        go (WNode a ts) = WNode (f a) [(w, go t) | (w, t) <- ts]

getVertexOrder :: Bounds -> [Int] -> UArray Int Int
getVertexOrder bnds p = runSTUArray $ do
  arr <- newArray bnds 0
  forM_ (zip [0..(snd bnds - 1)] p) $ \(i, el) -> do
    writeArray arr el i
  return arr

getEdges' :: forall s. Int -> Bounds -> WTree Int Vertex -> ST s (STUArray s Int Int)
getEdges' root bnds tree = do
  edges <- (newArray bnds 0) :: ST s (STUArray s Int Int)

  let dfs :: Int -> WTree Int Vertex -> ST s ()
      dfs w (WNode v ts) = do
        get_ <- readArray edges v
        writeArray edges v (w - get_)
        mapM_ (\(w, subts) -> dfs w subts) ts
  dfs 0 tree

  return edges

getEdges :: Int -> Bounds -> WTree Int Vertex -> UArray Int Int
getEdges root bnds tree = runSTUArray $ getEdges' root bnds tree

dfsCheckBad :: WTree Int Vertex -> Bool
dfsCheckBad (WNode v ts) = foldr (\(w,all@(WNode u ts')) suf -> suf || v > u || dfsCheckBad all) False ts

printlist xs = putStrLn s
  where (' ':s) = foldl (\pref el -> pref++" "++(show el)) "" xs

fita :: IO ()
fita = do
  [n] <- readInts
  mas <- readInts
  p <- readInts

  let vertexOrder = getVertexOrder (1,n) p
      g = buildWG (1,n) $ zipWith (\a b -> (b, (vertexOrder!a,a))) [1..n] mas
      root = fst . fromJust $ (find (\(a,b)->a==b) $ zip [1..n] mas)
      tree = dfsWTree g root

  if (dfsCheckBad ((vertexOrder!) <$> tree))
    then print (-1)
  else
    printlist . elems $ getEdges root (1,n) tree

main :: IO ()
main = flip replicateM_ fita =<< readLn

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Char8 as String
import qualified Data.ByteString.Builder.Prim as Prim
import Data.ByteString.Builder
import Control.Monad
import Control.Monad.ST
--import Control.Monad.Trans.State
import Data.Array.Base
import Data.Array.IO
import Data.Array.ST
import Data.Array.Unboxed
import Data.Array.MArray as Vector
import Data.Bits
import Data.Bool
import Data.Char
import Data.Graph
import Data.Int
import Data.List
import Data.Maybe
import Data.Ord
import Data.Ratio
import Data.Tuple
import Data.Function
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import System.IO
import System.IO.Unsafe
import System.Exit

import Data.IORef
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Fail
import Control.Applicative
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.IO.Class (liftIO)
import Data.Foldable (msum)
import Data.Char (isNumber, isPunctuation)

import Control.Monad.Identity (Identity(..))

printLog :: Show a => a -> a
printLog a = unsafePerformIO $ do putStrLn $ "{отладка[ "++show a ++ " ]отладка}"
                                  pure a

fArray :: Ix i => (i, i) -> (i -> a) -> Array i a
fArray b f = array b [(i, f i) | i <- range b]

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

type WEdge w = (Vertex, (w, Vertex))
type WGraph w = Array Vertex [(w, Vertex)]
data WTree w a = WNode { rootLabelW :: a
                       , subForestW :: [(w, WTree w a)]
                       } deriving Show

buildWG :: Bounds -> [WEdge w] -> WGraph w
buildWG = accumArray (flip (:)) []

dfsWTree :: WGraph w -> Vertex -> WTree w Vertex
dfsWTree g u = go u u where
    go p u = WNode u [(w, go u v) | (w, v) <- g!u, v /= p]

instance Functor (WTree w) where
    fmap f = go where
        go (WNode a ts) = WNode (f a) [(w, go t) | (w, t) <- ts]

getVertexOrder :: Bounds -> [Int] -> UArray Int Int
getVertexOrder bnds p = runSTUArray $ do
  arr <- newArray bnds 0
  forM_ (zip [0..(snd bnds - 1)] p) $ \(i, el) -> do
    writeArray arr el i
  return arr

getEdges' :: forall s. Int -> Bounds -> WTree Int Vertex -> ST s (STUArray s Int Int)
getEdges' root bnds tree = do
  edges <- (newArray bnds 0) :: ST s (STUArray s Int Int)

  let dfs :: Int -> WTree Int Vertex -> ST s ()
      dfs w (WNode v ts) = do
        get_ <- readArray edges v
        writeArray edges v (w - get_)
        mapM_ (\(w, subts) -> dfs w subts) ts
  dfs 0 tree

  return edges

getEdges :: Int -> Bounds -> WTree Int Vertex -> UArray Int Int
getEdges root bnds tree = runSTUArray $ getEdges' root bnds tree

dfsCheckBad :: WTree Int Vertex -> Bool
dfsCheckBad (WNode v ts) = foldr (\(w,all@(WNode u ts')) suf -> suf || v > u || dfsCheckBad all) False ts

fita :: IO ()
fita = do
  [n] <- readInts
  mas <- readInts
  p <- readInts

  let vertexOrder = getVertexOrder (1,n) p
      g = buildWG (1,n) $ zipWith (\a b -> (b, (vertexOrder!a,a))) [1..n] mas
      root = fst . fromJust $ (find (\(a,b)->a==b) $ zip [1..n] mas)
      tree = dfsWTree g root

  if (dfsCheckBad ((vertexOrder!) <$> tree))
    then print (-1)
  else
    print $ elems $ getEdges root (1,n) tree

main :: IO ()
main = flip replicateM_ fita =<< readLn


You are given an array $$$a$$$ of $$$n$$$ integers.You want to make all elements of $$$a$$$ equal to zero by doing the following operation exactly three times:  Select a segment, for each number in this segment we can add a multiple of $$$len$$$ to it, where $$$len$$$ is the length of this segment (added integers can be different). It can be proven that it is always possible to make all elements of $$$a$$$ equal to zero.

The first line contains one integer $$$n$$$ ($$$1 \le n \le 100\,000$$$): the number of elements of the array. The second line contains $$$n$$$ elements of an array $$$a$$$ separated by spaces: $$$a_1, a_2, \dots, a_n$$$ ($$$-10^9 \le a_i \le 10^9$$$).

The output should contain six lines representing three operations. For each operation, print two lines:   The first line contains two integers $$$l$$$, $$$r$$$ ($$$1 \le l \le r \le n$$$): the bounds of the selected segment.  The second line contains $$$r-l+1$$$ integers $$$b_l, b_{l+1}, \dots, b_r$$$ ($$$-10^{18} \le b_i \le 10^{18}$$$): the numbers to add to $$$a_l, a_{l+1}, \ldots, a_r$$$, respectively; $$$b_i$$$ should be divisible by $$$r - l + 1$$$.

--import Data.List
import Control.Monad
import Data.Int (Int64)

type Operation = (Int64, Int64, [Int64])

main :: IO ()
main = do
  n <- read <$> getLine
  a <- map read . words <$> getLine
  let
    ans :: [Operation]
    ans = case  n  of
      1 -> [(1,1, [0 - head a]), (1, 1, [0]), (1, 1, [0])]
      _ -> let
        p1 = (1, 1, [(n-1) * head a])
        p2 = (2, n, map (* (n-1)) (tail a))
        p3 = (1, n, map (* (0-n)) a)
        in [p1, p2, p3]
  forM_ ans $ \(l, r, incs) -> do
    putStrLn (unwords $ map show [l, r])
    putStrLn (unwords $ map show incs)

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

main = do
  n <- read <$> getLine
  as <- map read . words <$> getLine
  putStrLn "1 1"
  print (- head as)
  if n == 1
    then putStrLn "1 1\n0\n1 1\n0"
    else do
      putStrLn $ "2 " ++ show n
      let changes = (`mod` n) <$> tail as
      putStrLn $ unwords $ show . (* (n - 1)) <$> changes
      let changed = 0 : zipWith (\a change -> a + (n - 1) * change) (tail as) changes
      putStrLn $ "1 " ++ show n
      putStrLn $ unwords $ show . negate <$> changed


It is the middle of 2018 and Maria Stepanovna, who lives outside Krasnokamensk (a town in Zabaikalsky region), wants to rent three displays to highlight an important problem.There are $$$n$$$ displays placed along a road, and the $$$i$$$-th of them can display a text with font size $$$s_i$$$ only. Maria Stepanovna wants to rent such three displays with indices $$$i < j < k$$$ that the font size increases if you move along the road in a particular direction. Namely, the condition $$$s_i < s_j < s_k$$$ should be held.The rent cost is for the $$$i$$$-th display is $$$c_i$$$. Please determine the smallest cost Maria Stepanovna should pay.

The first line contains a single integer $$$n$$$ ($$$3 \le n \le 3\,000$$$) — the number of displays. The second line contains $$$n$$$ integers $$$s_1, s_2, \ldots, s_n$$$ ($$$1 \le s_i \le 10^9$$$) — the font sizes on the displays in the order they stand along the road. The third line contains $$$n$$$ integers $$$c_1, c_2, \ldots, c_n$$$ ($$$1 \le c_i \le 10^8$$$) — the rent costs for each display.

If there are no three displays that satisfy the criteria, print -1. Otherwise print a single integer — the minimum total rent cost of three displays with indices $$$i < j < k$$$ such that $$$s_i < s_j < s_k$$$.

NoteIn the first example you can, for example, choose displays $$$1$$$, $$$4$$$ and $$$5$$$, because $$$s_1 < s_4 < s_5$$$ ($$$2 < 4 < 10$$$), and the rent cost is $$$40 + 10 + 40 = 90$$$.In the second example you can't select a valid triple of indices, so the answer is -1.

module Main where

import Data.Traversable

infinite = 3 * 100000000 + 100

main :: IO ()
main = do
  n <- getLine
  fontsS <- getLine
  let fonts = map (read :: String -> Integer) $ words fontsS
  costsS <- getLine
  let costs = map (read :: String -> Integer) $ words costsS
  print $ solve fonts costs

solve :: [Integer] -> [Integer] -> Integer
solve (f1:f2:fs) (c1:c2:cs) = let answ = tryCost (f2, c2) [(f1,c1)] (zip fs cs) in
                              if answ == infinite
                              then -1
                              else answ

tryCost :: (Integer, Integer) -> [(Integer, Integer)] -> [(Integer, Integer)] -> Integer
tryCost _ _ [] = infinite
tryCost (f,c) left right = min (c + fnd True f left + fnd False f right ) (tryCost (head right) ((f,c):left) (tail right))
  where
  fnd :: Bool -> Integer -> [(Integer, Integer)] -> Integer
  fnd is_l c_font = foldl (\minim (fo,co) -> if co < minim && ((fo < c_font) == is_l) && (fo /= c_font)
                                                 then co
                                                 else minim
                              ) infinite

module Main where

import Data.Traversable

infinite = 3 * 100000000 + 100

main :: IO ()
main = do
  n <- getLine
  fontsS <- getLine
  let fonts = map (read :: String -> Integer) $ words fontsS
  costsS <- getLine
  let costs = map (read :: String -> Integer) $ words costsS
  print $ solve fonts costs

solve :: [Integer] -> [Integer] -> Integer
solve (f1:f2:fs) (c1:c2:cs) = let answ = tryCost (f2, c2) [(f1,c1)] (zip fs cs) in
                              if answ == infinite
                              then -1
                              else answ

tryCost :: (Integer, Integer) -> [(Integer, Integer)] -> [(Integer, Integer)] -> Integer
tryCost _ _ [] = infinite
tryCost (f,c) left right = min (c + (fnd True f left) + (fnd False f right) ) (tryCost (head right) ((f,c):left) (tail right))
  where
  fnd :: Bool -> Integer -> [(Integer, Integer)] -> Integer
  fnd is_l c_font lst = foldl (\minim (fo,co) -> if (co < minim && ((fo < c_font) == is_l) && not (fo == c_font))
                                                 then co
                                                 else minim
                              ) infinite lst

import Data.List

addLists :: [Int] -> [Int] -> [Int]
addLists a b = map (\(x, y) -> x + y) $ zip a b

getBest :: [(Int, Int)] -> Int -> Int
getBest [] _ = 400000000
getBest ((a, b) : tail) sz = if sz > a then min b $ getBest tail sz else getBest tail sz

solve :: [Int] -> [Int] -> [(Int, Int)] -> [Int]
solve [] [] [] = []
solve (a : tailA) (b : tailB) c = (getBest c a) : solve tailA tailB ((a, b) : c)
solve _ _ _ = []

main = do
    s <- getLine
    let n = read s :: Int
    s <- getLine
    let szs = map (read :: String -> Int) $ words s
    s <- getLine
    let costs = map (read :: String -> Int) $ words s
    let bestlr = solve szs costs []
    let bestrl = reverse $ solve (reverse $ map negate szs) (reverse costs) []
    let ans = minimum $ addLists costs $ addLists bestlr bestrl
    print $ if ans < 400000000 then ans else -1

import Data.List

findSmallest :: Int -> [(Int, Int)] -> Int
findSmallest sz scos = foldr (\(s,c) z -> if (s <= sz) then z else if (c < z) then c else z) 1000000009 scos

operate :: [(Int, Int)] -> [Int]
operate [] = []
operate (a:ax) =
    if (ax /= []) then ((findSmallest (fst a) ax) + (snd a)) : operate ax
    else (1000000009):[]

ffst :: (Int, Int, Int) -> Int
ffst (x, _, _) = x

ssnd :: (Int, Int, Int) -> Int
ssnd (_, x, _) = x

thd :: (Int, Int, Int) -> Int
thd (_, _, x) = x

findSmallest2 :: Int -> [(Int, Int, Int)] -> Int
findSmallest2 sz scos = foldr (\(s, _, c) z -> if (s <= sz) then z else if (c < z) then c else z) 1000000009 scos

operate2 :: [(Int, Int, Int)] -> [Int]
operate2 [] = []
operate2 (a:ax) =
    if (ax /= []) then ((findSmallest2 (ffst a) ax) + (ssnd a)) : operate2 ax
    else (1000000009):[]

main :: IO ()
main = do
    inp <- getLine
    let n = read inp :: Int
    sz <- getLine
    let sizes = map read (words sz)
    cs <- getLine
    let costs = map read (words cs)
    -- let sizes = take 3000 [3000, 2999..]
    -- let costs = take 3000 [100000000, 100000000..]
    let comp = operate (zip sizes costs)
    -- print comp
    let comp2 = operate2 (zip3 sizes costs comp)
    -- print comp2
    let res = foldr min 1000000009 comp2
    if (res >= 1000000009) then print (-1)
    else print res
    return ()

import Data.List

findSmallest :: Int -> [(Int, Int)] -> Int
findSmallest sz scos = foldr (\(s,c) z -> if (s <= sz) then z else if (c < z) then c else z) 1000000009 scos

operate :: [(Int, Int)] -> [Int]
operate [] = []
operate (a:ax) =
    if (ax /= []) then
        if (fst (head ax) > fst a) then let res = operate ax in
            if ((head res) < 2 * snd (head ax)) then ((head res) - snd (head ax) + snd a) : res else (snd (head ax) + snd a) : res
        else ((findSmallest (fst a) ax) + (snd a)) : operate ax
    else (1000000009):[]

ffst :: (Int, Int, Int) -> Int
ffst (x, _, _) = x

ssnd :: (Int, Int, Int) -> Int
ssnd (_, x, _) = x

thd :: (Int, Int, Int) -> Int
thd (_, _, x) = x

findSmallest2 :: Int -> [(Int, Int, Int)] -> Int
findSmallest2 sz scos = foldr (\(s, _, c) z -> if (s <= sz) then z else if (c < z) then c else z) 1000000009 scos

operate2 :: [(Int, Int, Int)] -> [Int]
operate2 [] = []
operate2 (a:ax) =
    if (ax /= []) then
        if (ffst (head ax) > ffst a) then let res = operate2 ax in
            if (head res == 1000000009) then ((findSmallest2 (ffst a) ax) + (ssnd a)) : res
            else if ((head res) - ssnd (head ax) < thd (head ax)) then ((head res) - ssnd (head ax) + ssnd a) : res else (thd (head ax) + ssnd a) : res
        else ((findSmallest2 (ffst a) ax) + (ssnd a)) : operate2 ax
    else (1000000009):[]

main :: IO ()
main = do
    inp <- getLine
    let n = read inp :: Int
    sz <- getLine
    let sizes = map read (words sz)
    cs <- getLine
    let costs = map read (words cs)
    let comp = operate (zip sizes costs)
    -- print comp
    let comp2 = operate2 (zip3 sizes costs comp)
    -- print comp2
    let res = foldr min 1000000009 comp2
    if (res >= 1000000009) then print (-1)
    else print res
    return ()


In this problem, your task is to use ASCII graphics to paint a cardiogram. A cardiogram is a polyline with the following corners:That is, a cardiogram is fully defined by a sequence of positive integers a1, a2, ..., an.Your task is to paint a cardiogram by given sequence ai.

The first line contains integer n (2 ≤ n ≤ 1000). The next line contains the sequence of integers a1, a2, ..., an (1 ≤ ai ≤ 1000). It is guaranteed that the sum of all ai doesn't exceed 1000.

Print max |yi - yj| lines (where yk is the y coordinate of the k-th point of the polyline), in each line print  characters. Each character must equal either « / » (slash), « \ » (backslash), « » (space). The printed image must be the image of the given polyline. Please study the test samples for better understanding of how to print a cardiogram. Note that in this problem the checker checks your answer taking spaces into consideration. Do not print any extra characters. Remember that the wrong answer to the first pretest doesn't give you a penalty.

NoteDue to the technical reasons the answers for the samples cannot be copied from the statement. We've attached two text documents with the answers below.http://assets.codeforces.com/rounds/435/1.txthttp://assets.codeforces.com/rounds/435/2.txt

-- @betaveros :: vim:set fdm=marker:
{-# LANGUAGE LambdaCase, NPlusKPatterns, ScopedTypeVariables, TupleSections #-}
{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-missing-signatures #-}
-- import ALL the things! {{{
-- hiding clauses are to allow Data.Foldable's generalizations
import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl, foldl1, foldr, foldr1, and, or, any, all, sum, product, concat, concatMap, maximum, minimum, elem, notElem)
import Control.Applicative
import Control.Arrow
import Control.Exception
import Control.Monad hiding (mapM, mapM_, forM, forM_, sequence, sequence_, msum)
import Control.Monad.ST

import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Char8 (ByteString)
import Data.Bits
import Data.Char
import Data.Either
import Data.Foldable
import Data.Function
import Data.IORef
import Data.List hiding (foldl, foldl', foldl1, foldl1', foldr, foldr1, concat, concatMap, and, or, any, all, sum, product, maximum, minimum, elem, notElem, find)
import Data.Maybe
import Data.Monoid
import Data.Ord
import Data.STRef
import Data.String
import Data.Traversable
import Data.Tuple

import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Sequence as Seq
import Data.Sequence (Seq, (<|), (|>), (><))

import Debug.Trace
import Text.Printf
import System.IO
-- }}}
-- silly utilities {{{
-- stolen from lens:
a & f = f a
a <&> f = fmap f a
infixl 1 &, <&>

fi :: (Integral a, Num b) => a -> b
fi = fromIntegral
glength :: (Num b) => [a] -> b
glength = genericLength

readInt     = read :: String -> Int
readInteger = read :: String -> Integer
-- (!?) :: (Ord k) => Map k v -> k -> Maybe v
-- (!?) = flip Map.lookup
histogram :: (Ord a, Num b) => [a] -> Map a b
histogram = Map.fromListWith (+) . map (,1)
-- }}}
-- input and output {{{
bsGetLine :: IO ByteString
bsGetLine = fst . BS.spanEnd isSpace <$> BS.getLine

inputInt     = (read <$> getLine) :: IO Int
inputInteger = (read <$> getLine) :: IO Integer
inputDouble  = (read <$> getLine) :: IO Double

inputRow :: (Read a) => IO [a]
inputRow = map read . words <$> getLine
inputInts     = inputRow :: IO [Int]
inputIntegers = inputRow :: IO [Integer]
inputDoubles  = inputRow :: IO [Double]

ssUnwords :: [ShowS] -> ShowS
ssUnwords [] = id
ssUnwords (x:xs) = x . (' ':) . ssUnwords xs

ssUnlines :: [ShowS] -> ShowS
ssUnlines [] = id
ssUnlines (x:xs) = x . ('\n':) . ssUnlines xs

showMany :: (Show a) => [a] -> String
showMany xs = ssUnwords (map shows xs) ""
showMatrix :: (Show a) => [[a]] -> String
showMatrix xs = ssUnlines (map (ssUnwords . map shows) xs) ""

printMany :: (Show a) => [a] -> IO ()
printMany xs = putStrLn (showMany xs)
printMatrix :: (Show a) => [[a]] -> IO ()
printMatrix xs = putStr (showMatrix xs)
-- }}}

cardioInc :: Int -> Int -> String
cardioInc top x = [if i == x then '\\' else ' ' | i <- [0..top-1]]
cardioDec :: Int -> Int -> String
cardioDec top x = [if i == x - 1 then '/' else ' ' | i <- [0..top-1]]

cardioTo :: Int -> Int -> Int -> [String]
cardioTo top x y
	| x < y = map (cardioInc top) [x..y-1]
	| x > y = map (cardioDec top) [x,x-1..y+1]
	| otherwise = error "what!?"

main :: IO ()
main = do
	void getLine
	xs <- inputInts
	let incs :: [Int] = zipWith (*) xs (cycle [1,-1])
	let stops' :: [Int] = scanl (+) 0 incs
	let bot = maximum stops'
	let stops = map (bot -) stops'
	let top = maximum stops
	let cols = concat $ zipWith (cardioTo top) stops (tail stops)
	-- print cols
	mapM_ putStrLn $ transpose cols


Recently Vasya got interested in finding extra-terrestrial intelligence. He made a simple extra-terrestrial signals’ receiver and was keeping a record of the signals for n days in a row. Each of those n days Vasya wrote a 1 in his notebook if he had received a signal that day and a 0 if he hadn’t. Vasya thinks that he has found extra-terrestrial intelligence if there is a system in the way the signals has been received, i.e. if all the intervals between successive signals are equal. Otherwise, Vasya thinks that the signals were sent by some stupid aliens no one cares about. Help Vasya to deduce from the information given by the receiver if he has found extra-terrestrial intelligence or not.

The first line contains integer n (3 ≤ n ≤ 100) — amount of days during which Vasya checked if there were any signals. The second line contains n characters 1 or 0 — the record Vasya kept each of those n days. It’s guaranteed that the given record sequence contains at least three 1s.

If Vasya has found extra-terrestrial intelligence, output YES, otherwise output NO.

import Data.List (findIndices, nub)
import IO

(<?>) :: a -> a -> Bool -> a
(<?>) a b p  =  if p then a else b

on :: (b -> c -> d) -> (a -> b) -> (a -> c) -> (a -> d)
on f g h x  =  f (g x) (h x)

solve :: String -> Bool
solve  =  (<= 1) . length . nub . on (zipWith (-)) id tail . findIndices (== '1')

main :: IO ()
main  =  do
    hInput   <-  openFile "input.txt" ReadMode
    hOutput  <-  openFile "output.txt" WriteMode

    hGetLine hInput >> hGetLine hInput >>= hPutStrLn hOutput . ("YES" <?> "NO") . solve

    hClose hInput
    hClose hOutput

import Prelude
import List
import Char

main = fileInteract q "input.txt" "output.txt"

q = func.lines

func::[String]->String
func (_:b:[]) = solve (map func' b)
                where
                  func'::Char->Int
                  func' a = toInt (a:[])
func _      = ""

fileInteract func inf ouf = do file <- readFile inf
                               writeFile ouf (func file)

toInt::String->Int
toInt = read

asInteger::String->Integer
asInteger = read

toString::Int->String
toString = show

solve::[Int]->String
solve b = case next of
            Nothing -> "NO"
            Just c -> case (solve' c (tail $ dropWhile (/=1) list)) of
                        True  -> "YES"
                        False -> "NO"
          where
            list = tail $ dropWhile (/=1) b
            next = elemIndex 1 list
            solve' a b = case next' of
                           Just c | a == c     -> solve' a $ drop (a+1) b
                                  | otherwise  -> False
                           Nothing             -> True
                    where
                      next' = elemIndex 1 b

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-}

import Control.Applicative
import Control.Monad
import Data.List
import Text.Printf

main :: IO ()
main = do
  let conv :: String -> [Int]
      conv = map read . words
      writeText = appendFile "output.txt"
  s : ss <- lines <$> readFile "input.txt"
  let signals = reverse . dropWhile (== '0') . reverse . dropWhile (== '0')
              $ head ss
      check n (c : cs)
        | c == '1'  = n : check 0 cs
        | otherwise = check (n + 1) cs
      check n _ = [n]
      zeros = tail . init $ check 0 signals
      ans = (!!) ["NO", "YES"] .  fromEnum . and
          $ zipWith (==) zeros (tail zeros)
  writeText $ printf "%s\n" (ans :: String)

main = do
  x <- readFile "input.txt"
  writeFile "output.txt" (f x)
f x = if (same $ tail $ interval signal) then "YES" else "NO" where
  [n0,signal] = lines x
  first [] = 0
  first ('0':xs)
    | y == 0    = 0
    | otherwise = y + 1
    where y = first xs
  first ('1':_) = 1
  interval [] = []
  interval xs
    | y==0      = []
    | otherwise = y:(interval $ drop y xs)
    where y = first xs
  same [_] = True
  same (y:z:xs) = if y/=z then False else same (z:xs)

import Data.List (nub)
import IO

(<?>) :: a -> a -> Bool -> a
(<?>) a b p  =  if p then a else b

on :: (b -> c -> d) -> (a -> b) -> (a -> c) -> (a -> d)
on f g h x  =  f (g x) (h x)

findIndices :: (a -> Bool) -> [a] -> [Int]
findIndices p xs  =  findIndices' $ zip xs [0..]
  where
    findIndices' []  =  []
    findIndices' ((x, n) : xs)
      | p x  =  n : findIndices' xs
      | otherwise  =  findIndices' xs

solve :: String -> Bool
solve  =  (<= 1) . length . nub . on (zipWith (-)) id tail . findIndices (== '1')

main :: IO ()
main  =  do
    hInput   <-  openFile "input.txt" ReadMode
    hOutput  <-  openFile "output.txt" WriteMode

    hGetLine hInput >>= hPutStrLn hOutput . ("YES" <?> "NO") . solve

    hClose hInput
    hClose hOutput


Luca has a cypher made up of a sequence of $$$n$$$ wheels, each with a digit $$$a_i$$$ written on it. On the $$$i$$$-th wheel, he made $$$b_i$$$ moves. Each move is one of two types:   up move (denoted by $$$\texttt{U}$$$): it increases the $$$i$$$-th digit by $$$1$$$. After applying the up move on $$$9$$$, it becomes $$$0$$$.  down move (denoted by $$$\texttt{D}$$$): it decreases the $$$i$$$-th digit by $$$1$$$. After applying the down move on $$$0$$$, it becomes $$$9$$$.     Example for $$$n=4$$$. The current sequence is 0 0 0 0. Luca knows the final sequence of wheels and the moves for each wheel. Help him find the original sequence and crack the cypher.

The first line contains a single integer $$$t$$$ ($$$1 \leq t \leq 100$$$) — the number of test cases. The first line of each test case contains a single integer $$$n$$$ ($$$1 \leq n \leq 100$$$) — the number of wheels. The second line contains $$$n$$$ integers $$$a_i$$$ ($$$0 \leq a_i \leq 9$$$) — the digit shown on the $$$i$$$-th wheel after all moves have been performed. Then $$$n$$$ lines follow, the $$$i$$$-th of which contains the integer $$$b_i$$$ ($$$1 \leq b_i \leq 10$$$) and $$$b_i$$$ characters that are either $$$\texttt{U}$$$ or $$$\texttt{D}$$$ — the number of moves performed on the $$$i$$$-th wheel, and the moves performed. $$$\texttt{U}$$$ and $$$\texttt{D}$$$ represent an up move and a down move respectively.

For each test case, output $$$n$$$ space-separated digits  — the initial sequence of the cypher.

3

3

9 3 1

3 DDD

4 UDUU

2 DU

2

0 9

9 DDDDDDDDD

9 UUUUUUUUU

5

0 5 9 8 3

10 UUUUUUUUUU

3 UUD

8 UUDUUDDD

10 UUDUUDUDDU

4 UUUU

NoteIn the first test case, we can prove that initial sequence was $$$[2,1,1]$$$. In that case, the following moves were performed:   On the first wheel: $$$2 \xrightarrow[\texttt{D}]{} 1 \xrightarrow[\texttt{D}]{} 0 \xrightarrow[\texttt{D}]{} 9$$$.  On the second wheel: $$$1 \xrightarrow[\texttt{U}]{} 2 \xrightarrow[\texttt{D}]{} 1 \xrightarrow[\texttt{U}]{} 2 \xrightarrow[\texttt{U}]{} 3$$$.  On the third wheel: $$$1 \xrightarrow[\texttt{D}]{} 0 \xrightarrow[\texttt{U}]{} 1$$$.  The final sequence was $$$[9,3,1]$$$, which matches the input.

import Control.Monad
import Data.List

solveSingle :: Int -> String -> Int
solveSingle n "" = n
solveSingle n ('D':s) =
    solveSingle (n+1) s
solveSingle n ('U':s) =
    solveSingle (n-1) s

solve :: [Int] -> [String] -> [Int]
solve [] [] = []
solve (a:as) (op:ops) =
    ((solveSingle a op) `mod` 10):(solve as ops)

testcase 0 = return ()
testcase t = do
    n <- readLn :: IO Int
    arr <- map (read :: String -> Int) <$> words <$> getLine
    ops <- map (\x -> last $ words x) <$> forM [1..n] (\x -> getLine)
    putStrLn $ unwords $ map show $ solve arr ops
    testcase (t - 1)

main :: IO ()
main = do
    t <- read <$> getLine
    testcase t

import Control.Monad
import Data.List

solve' :: Int -> String -> Int
solve' n "" = n
solve' n ('D':s) =
    solve' (n+1) s
solve' n ('U':s) =
    solve' (n-1) s

solve :: [Int] -> [String] -> [Int]
solve [] [] = []
solve (a:as) (op:ops) =
    ((solve' a op) `mod` 10):(solve as ops)

testcase 0 = return ()
testcase t = do
    n <- readLn :: IO Int
    arr <- map (read :: String -> Int) <$> words <$> getLine
    ops <- map (\x -> last $ words x) <$> forM [1..n] (\x -> getLine)
    putStrLn $ unwords $ map show $ solve arr ops
    testcase (t - 1)

main :: IO ()
main = do
    t <- read <$> getLine
    testcase t

{-# LANGUAGE LambdaCase #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort, nub, intercalate)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Data.Function (on)
-- import System.Random
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Debug.Trace
import Data.Bool (bool)
import Data.Foldable (foldlM)
import Control.Arrow ((&&&))
import Data.String (fromString)

-- road map in reverse, and the number of cities, init pen state
type Domain = ([Int], [Int])
type CoDomain = [Int]
type Solver  = Domain -> CoDomain

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

printAns :: CoDomain -> IO ()
printAns xs = putStrLn $ intercalate " " $ map show xs

toNum :: Char -> Int
toNum 'U' = -1
toNum _ = 1

parse :: IO Domain
parse = do
  [n] <- readChar8
  xs <- readChar8
  operations <- replicateM n getLine
  let ops = ((`mod` 10) . sum . map toNum. (!!1). words) <$> operations
  return (xs, ops)

solve :: Solver
solve = uncurry (zipWith (\x y -> (x + y) `mod` 10))

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

module Main (main) where
import Numeric (showFFloat)
import Data.Char (toUpper)
import Control.Monad
import qualified Data.Foldable as String

import qualified Data.Set as Set

-- reset && stack build && echo "success" && stack exec haskell-codeforces-exe && echo finished
--  gen-hie > hie.yaml

strToInt a = read a :: Int
strToFloat a = read a :: Float

pshow x = putStr (show x)
pfshow x = putStr (showFFloat (Just 2) x "")

getDelta 'U' = -1
getDelta 'D' = 1

calc :: (Int, String) -> Int
calc (value, changesS) = do
    let changes = last $ words changesS
    let delta = sum $ map getDelta changes
    (value + delta) `mod` 10

solve :: IO()
solve = do
    n <- getLine
    valuesS <- getLine

    let values = map strToInt $ words valuesS
    changes <- replicateM (read n) getLine

    let ff = zip values changes

    let res = map calc ff

    putStrLn $ concatMap ((++ " ") . show) res

main :: IO ()
main = do
    n <- readLn
    replicateM_ n solve

{-# LANGUAGE ScopedTypeVariables #-}

import Data.List
import Control.Monad
--import Control.Monad.State.Strict

-- parseLine = fmap (map read . words)

toSpaced :: Show a => [a] -> String
toSpaced = intercalate " " . map show

printSpaced :: Show a => [a] -> IO ()
printSpaced = putStrLn . toSpaced

readInt :: IO Int
readInt = fmap read getLine
readInts :: IO [Int]
readInts = fmap (map read . words) getLine

f :: Int -> Int -> Int
f x y = mod (x - y + 10) 10

main :: IO ()
main = do
    t <- readInt
    forM_ [1..t] $ \t -> do
        n <- readInt
        a <- readInts

        offsets <- (forM [1..n] $ \i -> do
            line <- getLine;
            let [b_i_s, s_i] = words line;
            -- print $ (b_i_s, s_i)
            let b_i :: Int = read b_i_s;
            let up_count = (length . filter (=='U')) s_i;
            let down_count = (length . filter (=='D')) s_i;
            return $ up_count - down_count)

        let res :: [Int] = zipWith f a offsets
        printSpaced res
        return ()

import Control.Category ((>>>))
import Control.Monad (replicateM, replicateM_)
import Data.Function ((&))
import Data.Functor ((<&>))

main = do
    tests_n <- getLine <&> read
    replicateM_ tests_n $ do
        wheels_n <- getLine <&> read
        final_wheels <- getLine <&> (words >>> map read)
        wheels_offsets <- replicateM wheels_n $ do
            actions <- getLine <&> words <&> last
            return (count 'U' actions - count 'D' actions)
        let initial_wheels = zipWith (-) final_wheels wheels_offsets & map (`mod` 10)
        putStrLn (initial_wheels & map show & unwords)

count x = filter (== x) >>> length

import Control.Monad
import Data.List

count :: Eq a => a -> [a] -> Int
count elem xs = length (filter (==elem) xs)

solve :: [Int] -> [String] -> [Int]
solve a strs = map (\(x, y) -> (10 + (x - y) `mod` 10) `mod` 10) (zip a b)
    where b = map (\x -> count 'U' x - count 'D' x) strs

testCaseMain :: Int -> IO ()
testCaseMain _ = do n <- (readLn :: IO Int)
                    a <- map (read :: String -> Int) <$> words <$> getLine
                    strs <- map (head . tail . words) <$> forM [1 .. n] (\_ -> getLine)
                    putStrLn (unwords (map show (solve a strs)))

main :: IO ()
main = do n <- (readLn :: IO Int)
          forM_ [1 .. n] testCaseMain

import           Data.List
import qualified Data.Char as DC
import Control.Monad (replicateM)

leq :: Char -> String -> Int
leq c s = (length $ filter (== c) s)

solveN :: IO Int
solveN = do
    line <- fmap (\x -> (words x) !! 1) getLine
    let val = ((leq 'D' line) - (leq 'U' line)) `mod` 10
    --putStr $ show val
    --putStr " "
    return val

solveCase :: IO ()
solveCase = do
    n <- fmap (read :: String -> Int) getLine
    arr <- fmap (\x -> map (read :: String -> Int) $ words x) getLine
    res <- replicateM n solveN
    putStrLn $ unwords $ map show $ map (\x -> ((fst x) + (snd x)) `mod` 10) $ zip arr res

solve :: Int -> IO ()
solve 0 = do
    return ()
solve cases_left = do
    solveCase
    solve $ cases_left - 1

main = do
    s_testcases <- getLine
    solve $ (read s_testcases :: Int)

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

import Control.Applicative (Applicative (liftA2))
import Control.Arrow ((>>>))
import Control.Monad (forM_)
import Control.Monad.State (MonadState (get, put), State, evalState, gets, replicateM)
import Data.Array ((!))
import Data.Array.ST (MArray (newArray), readArray, runSTArray, writeArray)
import qualified Data.ByteString.Char8 as C
import Data.Char (toLower)
import Data.List (nub, sort)
import Data.Maybe (fromJust)

data TC = TC {n :: Int, a :: [Int], steps :: [String]}

solve TC {..} = unwords $ fmap show res
  where
    stepsI = fmap (sum . fmap (\case 'U' -> (-1); _ -> 1)) steps
    res = fmap (`mod` 10) $ zipWith (+) a stepsI

main = C.interact $ runScanner scan >>> map solve >>> map (C.pack) >>> C.unlines

scan = numberOf $ do
  n <- int
  a <- n >< int
  steps <- n >< (C.unpack <$> (int >> str))
  pure $ TC n a steps

type Scanner = State [C.ByteString]

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

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

peek :: Scanner C.ByteString
peek = gets head

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

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

integer :: Scanner Integer
integer = read . C.unpack <$> str

double :: Scanner Double
double = read . C.unpack <$> str

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

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

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

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

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

(><) = times

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

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


Pikachu had an array with him. He wrote down all the non-empty subsequences of the array on paper. Note that an array of size n has 2n - 1 non-empty subsequences in it. Pikachu being mischievous as he always is, removed all the subsequences in which Maximum_element_of_the_subsequence  -  Minimum_element_of_subsequence  ≥ dPikachu was finally left with X subsequences. However, he lost the initial array he had, and now is in serious trouble. He still remembers the numbers X and d. He now wants you to construct any such array which will satisfy the above conditions. All the numbers in the final array should be positive integers less than 1018. Note the number of elements in the output array should not be more than 104. If no answer is possible, print  - 1.

The only line of input consists of two space separated integers X and d (1 ≤ X, d ≤ 109).

Output should consist of two lines. First line should contain a single integer n (1 ≤ n ≤ 10 000)— the number of integers in the final array. Second line should consist of n space separated integers — a1, a2, ... , an (1 ≤ ai < 1018). If there is no answer, print a single integer -1. If there are multiple answers, print any of them.

NoteIn the output of the first example case, the remaining subsequences after removing those with Maximum_element_of_the_subsequence  -  Minimum_element_of_subsequence  ≥ 5 are [5], [5, 7], [5, 6], [5, 7, 6], [50], [7], [7, 6], [15], [6], [100]. There are 10 of them. Hence, the array [5, 50, 7, 15, 6, 100] is valid.Similarly, in the output of the second example case, the remaining sub-sequences after removing those with Maximum_element_of_the_subsequence  -  Minimum_element_of_subsequence  ≥ 2 are [10], [100], [1000], [10000]. There are 4 of them. Hence, the array [10, 100, 1000, 10000] is valid.

f :: Integer -> Integer
f x = 2^x - 1

g :: Integer -> [Integer]
g 0 = []
g x = y:g (x - f y)
      where (l, r) = break (\ a -> f a > x) [1..30]
            y = last l

main = do
          l1 <- getLine
          let x:d:as = map read.words $ l1
          let ans = snd.foldr (\ a (c, b) -> (c + d + 1, replicate (fromIntegral a) c ++ b)) (1, []).g $ x
          putStrLn.show.length $ ans
          putStrLn.unwords.map show $ ans

f :: Int -> Int
f x = 2^x - 1

g :: Int -> [Int]
g 0 = []
g x = y:g (x - f y)
      where (l, r) = break (\ a -> f a > x) [1..30]
            y = last l

main = do
          l1 <- getLine
          let x:d:as = map read.words $ l1
          let ans = snd.foldr (\ a (c, b) -> (c + d + 1, replicate a c ++ b)) (1, []).g $ x
          putStrLn.show.length $ ans
          putStrLn.unwords.map show $ ans

f :: Integral a => a -> a
f x = 2^x - 1

g :: Integral a => a -> [a]
g 0 = []
g x = y:g (x - f y)
      where (l, r) = break (\ a -> f a > x) [1..30]
            y = last l

main = do
          l1 <- getLine
          let x:d:as = map read.words $ l1
          let ans = snd.foldr (\ a (c, b) -> (c + d + 1, replicate a c ++ b)) (1, []).g $ x
          putStrLn.show.length $ ans
          putStrLn.unwords.map show $ ans


Parmida is a clever girl and she wants to participate in Olympiads this year. Of course she wants her partner to be clever too (although he's not)! Parmida has prepared the following test problem for Pashmak.There is a sequence a that consists of n integers a1, a2, ..., an. Let's denote f(l, r, x) the number of indices k such that: l ≤ k ≤ r and ak = x. His task is to calculate the number of pairs of indicies i, j (1 ≤ i < j ≤ n) such that f(1, i, ai) > f(j, n, aj).Help Pashmak with the test.

The first line of the input contains an integer n (1 ≤ n ≤ 106). The second line contains n space-separated integers a1, a2, ..., an (1 ≤ ai ≤ 109).

Print a single integer — the answer to the problem.

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

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

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

numLoop :: (Num a, Ord a, Monad m) => a -> a -> (a -> m ()) -> m ()
numLoop start end f = if start <= end then go start else return ()
  where
    go !x | x == end  = f x
          | otherwise = f x >> go (x+1)

{-# INLINE numLoop #-}

qsort gen xs = runSTUArray $ do
    let n = length xs
    a <- newListArray (1, n) xs :: ST s (STUArray s Int Int)
    gr <- newSTRef gen

    let sort' l r = when (l < r) $ do
        g <- readSTRef gr
        let (x, g') = randomR (l, r-1) g
        writeSTRef gr g'

        s <- readArray a x
        let loop i j
              | i > j = return (i, j)
              | otherwise = do
                ai <- readArray a i
                aj <- readArray a j
                case () of
                  _ | ai < s -> loop (i+1) j
                    | aj > s -> loop i (j-1)
                    | otherwise -> do
                        writeArray a i aj
                        writeArray a j ai
                        loop (i+1) (j-1)

        (i, j) <- loop l r

        sort' l j
        sort' i r

    sort' 1 n
    return a

main = do
  n <- readLn
  as <- getInts
  gen <- newStdGen

  let
    as' = map lookup as
      where
        a = qsort gen as

        lookup x = lookup' 1 n
          where
            lookup' l r =
              case compare x (a!m) of
                EQ -> m
                LT -> lookup' l (m-1)
                GT -> lookup' (m+1) r
              where m = (l+r)`div`2

  cnt1 :: IOUArray Int Int <- newArray (1, n) 0
  ls :: IOUArray Int Int <- newArray_ (1, n)
  forM_ (zip [1..n] as') $ \(i, x) -> do
    c <- readArray cnt1 x
    writeArray cnt1 x $ c+1
    writeArray ls i $ c+1

  cnt2 :: IOUArray Int Int <- newArray (1, n) 0
  rs :: IOUArray Int Int <- newArray_ (1, n)
  forM_ (reverse $ zip [1..n] as') $ \(i, x) -> do
    c <- readArray cnt2 x
    writeArray cnt2 x $ c+1
    writeArray rs i $ c+1

  {- let
    acc :: IntMap Int -> Int -> (IntMap Int, Int)
    acc !m a = (m', c)
      where
        !m' = IntMap.insertWith (+) a 1 m
        !c = fromIntegral $ m' IntMap.! a

  ls :: IOUArray Int Int <- newListArray (1, n) $ snd $ mapAccumL acc IntMap.empty as
  rs :: IOUArray Int Int <- newListArray (1, n) $ snd $ mapAccumR acc IntMap.empty as -}

  t :: IOUArray Int Int <- newArray_ (1, n)

  let
    solve l r
      | l == r = return 0
      | otherwise = do
        c1 <- solve l m
        c2 <- solve (m+1) r

        c <- count l (m+1) (0 :: Int64)

        merge ls l m r
        merge rs l m r

        return $ c1+c2+c
      where
        m = (l+r) `div` 2

        count i j !c
          | i == m+1 = return c
          | j == r+1 = count (i+1) j $ c + fromIntegral (j-(m+1))
          | otherwise = do
            l <- readArray ls i
            r <- readArray rs j

            if l <= r
              then count (i+1) j $ c + fromIntegral (j-(m+1))
              else count i (j+1) c

        {-# INLINE merge #-}
        merge a l m r = do
            merge' l (m+1) 1

            numLoop 1 (r-l+1) $ \i -> readArray t i >>= writeArray a (l+i-1)
          where
            merge' i j k
              | i == m+1 && j == r+1 = return ()
              | i == m+1 = readArray a j >>= writeArray t k >> merge' i (j+1) (k+1)
              | j == r+1 = readArray a i >>= writeArray t k >> merge' (i+1) j (k+1)
              | otherwise = do
                x <- readArray a i
                y <- readArray a j

                if x <= y
                  then writeArray t k x >> merge' (i+1) j (k+1)
                  else writeArray t k y >> merge' i (j+1) (k+1)

  r <- solve 1 n

  print r

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

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

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

numLoop :: (Num a, Ord a, Monad m) => a -> a -> (a -> m ()) -> m ()
numLoop start end f = if start <= end then go start else return ()
  where
    go !x | x == end  = f x
          | otherwise = f x >> go (x+1)

{-# INLINE numLoop #-}

qsort gen xs = runSTUArray $ do
    let n = length xs
    a <- newListArray (1, n) xs :: ST s (STUArray s Int Int)
    gr <- newSTRef gen

    let sort' l r = when (l < r) $ do
        g <- readSTRef gr
        let (x, g') = randomR (l, r-1) g
        writeSTRef gr g'

        s <- readArray a x
        let loop i j
              | i > j = return (i, j)
              | otherwise = do
                ai <- readArray a i
                aj <- readArray a j
                case () of
                  _ | ai < s -> loop (i+1) j
                    | aj > s -> loop i (j-1)
                    | otherwise -> do
                        writeArray a i aj
                        writeArray a j ai
                        loop (i+1) (j-1)

        (i, j) <- loop l r

        sort' l j
        sort' i r

    sort' 1 n
    return a

main = do
  n <- readLn
  as <- getInts
  gen <- newStdGen

  let
    as' = map lookup as
      where
        a = qsort gen as

        lookup x = lookup' 1 n
          where
            lookup' l r =
              case compare x (a!m) of
                EQ -> m
                LT -> lookup' l (m-1)
                GT -> lookup' (m+1) r
              where m = (l+r)`div`2

  cnt1 :: IOUArray Int Int <- newArray (1, n) 0
  ls :: IOUArray Int Int <- newArray_ (1, n)
  forM_ (zip [1..n] as') $ \(i, x) -> do
    c <- readArray cnt1 x
    writeArray cnt1 x $ c+1
    writeArray ls i $ c+1

  cnt2 :: IOUArray Int Int <- newArray (1, n) 0
  rs :: IOUArray Int Int <- newArray_ (1, n)
  forM_ (reverse $ zip [1..n] as') $ \(i, x) -> do
    c <- readArray cnt2 x
    writeArray cnt2 x $ c+1
    writeArray rs i $ c+1

  {- let
    acc :: IntMap Int -> Int -> (IntMap Int, Int)
    acc !m a = (m', c)
      where
        !m' = IntMap.insertWith (+) a 1 m
        !c = fromIntegral $ m' IntMap.! a

  ls :: IOUArray Int Int <- newListArray (1, n) $ snd $ mapAccumL acc IntMap.empty as
  rs :: IOUArray Int Int <- newListArray (1, n) $ snd $ mapAccumR acc IntMap.empty as -}

  t :: IOUArray Int Int <- newArray_ (1, n)

  let
    solve l r
      | l == r = return 0
      | otherwise = do
        c1 <- solve l m
        c2 <- solve (m+1) r

        c <- count l (m+1) (0 :: Int64)

        merge ls l m r
        merge rs l m r

        return $ c1+c2+c
      where
        m = (l+r) `div` 2

        count i j !c
          | i == m+1 = return c
          | j == r+1 = count (i+1) j $ c + fromIntegral (j-(m+1))
          | otherwise = do
            l <- readArray ls i
            r <- readArray rs j

            if l <= r
              then count (i+1) j $ c + fromIntegral (j-(m+1))
              else count i (j+1) c

        merge a l m r = do
            merge' l (m+1) 1

            numLoop 1 (r-l+1) $ \i -> readArray t i >>= writeArray a (l+i-1)
          where
            merge' i j k
              | i == m+1 && j == r+1 = return ()
              | i == m+1 = readArray a j >>= writeArray t k >> merge' i (j+1) (k+1)
              | j == r+1 = readArray a i >>= writeArray t k >> merge' (i+1) j (k+1)
              | otherwise = do
                x <- readArray a i
                y <- readArray a j

                if x <= y
                  then writeArray t k x >> merge' (i+1) j (k+1)
                  else writeArray t k y >> merge' i (j+1) (k+1)

  r <- solve 1 n

  print r

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

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

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

numLoop :: (Num a, Ord a, Monad m) => a -> a -> (a -> m ()) -> m ()
numLoop start end f = if start <= end then go start else return ()
  where
    go !x | x == end  = f x
          | otherwise = f x >> go (x+1)

{-# INLINE numLoop #-}

qsort gen xs = runSTUArray $ do
    let n = length xs
    a <- newListArray (1, n) xs :: ST s (STUArray s Int Int)
    gr <- newSTRef gen

    let sort' l r = when (l < r) $ do
        g <- readSTRef gr
        let (x, g') = randomR (l, r-1) g
        writeSTRef gr g'

        s <- readArray a x
        let loop i j
              | i > j = return (i, j)
              | otherwise = do
                ai <- readArray a i
                aj <- readArray a j
                case () of
                  _ | ai < s -> loop (i+1) j
                    | aj > s -> loop i (j-1)
                    | otherwise -> do
                        writeArray a i aj
                        writeArray a j ai
                        loop (i+1) (j-1)

        (i, j) <- loop l r

        sort' l j
        sort' i r

    sort' 1 n
    return a

main = do
  n <- readLn
  as <- getInts
  gen <- newStdGen

  let
    as' = map lookup as
      where
        a = qsort gen as

        lookup x = lookup' 1 n
          where
            lookup' l r =
              case compare x (a!m) of
                EQ -> m
                LT -> lookup' l (m-1)
                GT -> lookup' (m+1) r
              where m = (l+r)`div`2

  cnt1 :: IOUArray Int Int <- newArray (1, n) 0
  ls :: IOUArray Int Int <- newArray_ (1, n)
  forM_ (zip [1..n] as') $ \(i, x) -> do
    c <- readArray cnt1 x
    writeArray cnt1 x $ c+1
    writeArray ls i $ c+1

  cnt2 :: IOUArray Int Int <- newArray (1, n) 0
  rs :: IOUArray Int Int <- newArray_ (1, n)
  forM_ (reverse $ zip [1..n] as') $ \(i, x) -> do
    c <- readArray cnt2 x
    writeArray cnt2 x $ c+1
    writeArray rs i $ c+1

  {- let
    acc :: IntMap Int -> Int -> (IntMap Int, Int)
    acc !m a = (m', c)
      where
        !m' = IntMap.insertWith (+) a 1 m
        !c = fromIntegral $ m' IntMap.! a

  ls :: IOUArray Int Int <- newListArray (1, n) $ snd $ mapAccumL acc IntMap.empty as
  rs :: IOUArray Int Int <- newListArray (1, n) $ snd $ mapAccumR acc IntMap.empty as -}

  t :: IOUArray Int Int <- newArray_ (1, n)

  let
    solve l r
      | l == r = return 0
      | otherwise = do
        c1 <- solve l m
        c2 <- solve (m+1) r

        c <- count l (m+1) (0 :: Int64)

        merge ls l m r
        merge rs l m r

        let !s = c1+c2+c
        return s
      where
        m = (l+r) `div` 2

        count i j !c
          | i == m+1 = return c
          | j == r+1 = count (i+1) j $ c + fromIntegral (j-(m+1))
          | otherwise = do
            l <- readArray ls i
            r <- readArray rs j

            if l <= r
              then count (i+1) j $ c + fromIntegral (j-(m+1))
              else count i (j+1) c

        {-# INLINE merge #-}
        merge a l m r = do
            merge' l (m+1) 1

            numLoop 1 (r-l+1) $ \i -> readArray t i >>= writeArray a (l+i-1)
          where
            merge' i j k
              | i == m+1 && j == r+1 = return ()
              | i == m+1 = readArray a j >>= writeArray t k >> merge' i (j+1) (k+1)
              | j == r+1 = readArray a i >>= writeArray t k >> merge' (i+1) j (k+1)
              | otherwise = do
                x <- readArray a i
                y <- readArray a j

                if x <= y
                  then writeArray t k x >> merge' (i+1) j (k+1)
                  else writeArray t k y >> merge' i (j+1) (k+1)

  r <- solve 1 n

  print r

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

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

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

main = do
  n <- readLn
  as <- getInts

  let
    as' = map lookup as
      where
        a :: UArray Int Int = listArray (1, n) $ sort as

        lookup x = lookup' 1 n
          where
            lookup' l r
              | x == v = m
              | x < v = lookup' 1 (m-1)
              | x > v = lookup' (m+1) r
              where
                m = (l+r)`div`2
                v = a!m

  cnt1 :: IOUArray Int Int <- newArray (1, n) 0
  ls :: IOUArray Int Int <- newArray_ (1, n)
  forM_ (zip [1..n] as') $ \(i, x) -> do
    c <- readArray cnt1 x
    writeArray cnt1 x $ c+1
    writeArray ls i $ c+1

  cnt2 :: IOUArray Int Int <- newArray (1, n) 0
  rs :: IOUArray Int Int <- newArray_ (1, n)
  forM_ (reverse $ zip [1..n] as') $ \(i, x) -> do
    c <- readArray cnt2 x
    writeArray cnt2 x $ c+1
    writeArray rs i $ c+1

  t :: IOUArray Int Int <- newArray_ (1, n)

  let
    solve l r
      | l == r = return 0
      | otherwise = do
        c1 <- solve l m
        c2 <- solve (m+1) r

        c <- count l (m+1) 0

        merge ls l m r
        merge rs l m r

        return $ c1+c2+c
      where
        m = (l+r) `div` 2

        count i j c
          | i == m+1 = return c
          | j == r+1 = count (i+1) j $ c + j-(m+1)
          | otherwise = do
            l <- readArray ls i
            r <- readArray rs j

            if l <= r
              then count (i+1) j $ c + j-(m+1)
              else count i (j+1) c

        merge a l m r = do
            merge' l (m+1) 1

            forM_ [1..r-l+1] $ \i -> readArray t i >>= writeArray a (l+i-1)
          where
            merge' i j k
              | i == m+1 && j == r+1 = return ()
              | i == m+1 = readArray a j >>= writeArray t k >> merge' i (j+1) (k+1)
              | j == r+1 = readArray a i >>= writeArray t k >> merge' (i+1) j (k+1)
              | otherwise = do
                x <- readArray a i
                y <- readArray a j

                if x <= y
                  then writeArray t k x >> merge' (i+1) j (k+1)
                  else writeArray t k y >> merge' i (j+1) (k+1)

  r <- solve 1 n

  print r


Word $$$s$$$ of length $$$n$$$ is called $$$k$$$-complete if   $$$s$$$ is a palindrome, i.e. $$$s_i=s_{n+1-i}$$$ for all $$$1 \le i \le n$$$;  $$$s$$$ has a period of $$$k$$$, i.e. $$$s_i=s_{k+i}$$$ for all $$$1 \le i \le n-k$$$. For example, "abaaba" is a $$$3$$$-complete word, while "abccba" is not.Bob is given a word $$$s$$$ of length $$$n$$$ consisting of only lowercase Latin letters and an integer $$$k$$$, such that $$$n$$$ is divisible by $$$k$$$. He wants to convert $$$s$$$ to any $$$k$$$-complete word.To do this Bob can choose some $$$i$$$ ($$$1 \le i \le n$$$) and replace the letter at position $$$i$$$ with some other lowercase Latin letter.So now Bob wants to know the minimum number of letters he has to replace to convert $$$s$$$ to any $$$k$$$-complete word.Note that Bob can do zero changes if the word $$$s$$$ is already $$$k$$$-complete.You are required to answer $$$t$$$ test cases independently.

The first line contains a single integer $$$t$$$ ($$$1 \le t\le 10^5$$$) — the number of test cases. The first line of each test case contains two integers $$$n$$$ and $$$k$$$ ($$$1 \le k < n \le 2 \cdot 10^5$$$, $$$n$$$ is divisible by $$$k$$$). The second line of each test case contains a word $$$s$$$ of length $$$n$$$. It is guaranteed that word $$$s$$$ only contains lowercase Latin letters. And it is guaranteed that the sum of $$$n$$$ over all test cases will not exceed $$$2 \cdot 10^5$$$.

For each test case, output one integer, representing the minimum number of characters he has to replace to convert $$$s$$$ to any $$$k$$$-complete word.

4
6 2
abaaba
6 3
abaaba
36 9
hippopotomonstrosesquippedaliophobia
21 7
wudixiaoxingxingheclp

NoteIn the first test case, one optimal solution is aaaaaa.In the second test case, the given word itself is $$$k$$$-complete.

import Data.List

main = getLine >>= test . read

test 0 = return ()
test t = do
    (n:k:_) <- map read . words <$> getLine
    s <- getLine
    let is = cycle $ makePalindrome k
    print $ sum [sum a - maximum a | a <- map (map length . group . sort . map fst) $ groupBy (equating snd) $ sortOn snd $ zip s is]
    test $ pred t

equating f a b = f a == f b

makePalindrome k
    | odd k = is ++ (div k 2 + 1) : reverse is
    | otherwise = is ++ reverse is
  where
    is = [1 .. div k 2]


Alyona decided to go on a diet and went to the forest to get some apples. There she unexpectedly found a magic rooted tree with root in the vertex 1, every vertex and every edge of which has a number written on.The girl noticed that some of the tree's vertices are sad, so she decided to play with them. Let's call vertex v sad if there is a vertex u in subtree of vertex v such that dist(v, u) > au, where au is the number written on vertex u, dist(v, u) is the sum of the numbers written on the edges on the path from v to u.Leaves of a tree are vertices connected to a single vertex by a single edge, but the root of a tree is a leaf if and only if the tree consists of a single vertex — root.Thus Alyona decided to remove some of tree leaves until there will be no any sad vertex left in the tree. What is the minimum number of leaves Alyona needs to remove?

In the first line of the input integer n (1 ≤ n ≤ 105) is given — the number of vertices in the tree. In the second line the sequence of n integers a1, a2, ..., an (1 ≤ ai ≤ 109) is given, where ai is the number written on vertex i. The next n - 1 lines describe tree edges: ith of them consists of two integers pi and ci (1 ≤ pi ≤ n,  - 109 ≤ ci ≤ 109), meaning that there is an edge connecting vertices i + 1 and pi with number ci written on it.

Print the only integer — the minimum number of leaves Alyona needs to remove such that there will be no any sad vertex left in the tree.

NoteThe following image represents possible process of removing leaves from the tree:

import Control.Applicative
import Control.Monad
import Control.Monad.Trans.State.Strict
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Char
import Data.Graph
import qualified Data.IntMap as IM
import Data.IntMap ((!))
import qualified Data.IntMap.Strict as IMS
import Data.Ix (Ix, index, range)
import Data.List
import Data.Tree

main = do
    s <- B.getContents
    let (n,a,e) = flip evalState s $ do
        n <- readInt
        a <- replicateM n readInt
        let readEdge = (,) <$> readInt <*> readInt
        e <- replicateM (n-1) readEdge
        return (n, a, e)
    print $ solve n a e

solve n v epairs = n - count tree 0
  where
    a = IMS.fromList (zip [0..] v)
    canon a b = (min a b, max a b)
    e = [(canon i (p-1), c) | (i,(p, c)) <- zip [1..] epairs]
    g0 = buildG (0, n-1) $ map fst e
    g = buildG (0, n-1) $ edges g0 ++ edges (transposeG g0)
    rng = ((0,0), (n-1,n-1))
    len = IMS.fromList [(index rng a, c) | (a, c) <- e]
    tree = head $ dfs g [0]

    count t cur | a!(rootLabel t) < cur  = 0
    count t cur = 1 + sum [count s (upd cur t s) | s <- subForest t]

    upd cur t s = max 0 (cur + len!(index rng pair))
      where pair = canon (rootLabel t) (rootLabel s)

readInt :: State B.ByteString Int
readInt = do
    Just (n, rest) <- gets (B.readInt . B.dropWhile isSpace)
    put rest
    return n


Now that Kuroni has reached 10 years old, he is a big boy and doesn't like arrays of integers as presents anymore. This year he wants a Bracket sequence as a Birthday present. More specifically, he wants a bracket sequence so complex that no matter how hard he tries, he will not be able to remove a simple subsequence!We say that a string formed by $$$n$$$ characters '(' or ')' is simple if its length $$$n$$$ is even and positive, its first $$$\frac{n}{2}$$$ characters are '(', and its last $$$\frac{n}{2}$$$ characters are ')'. For example, the strings () and (()) are simple, while the strings )( and ()() are not simple.Kuroni will be given a string formed by characters '(' and ')' (the given string is not necessarily simple). An operation consists of choosing a subsequence of the characters of the string that forms a simple string and removing all the characters of this subsequence from the string. Note that this subsequence doesn't have to be continuous. For example, he can apply the operation to the string ')()(()))', to choose a subsequence of bold characters, as it forms a simple string '(())', delete these bold characters from the string and to get '))()'. Kuroni has to perform the minimum possible number of operations on the string, in such a way that no more operations can be performed on the remaining string. The resulting string does not have to be empty.Since the given string is too large, Kuroni is unable to figure out how to minimize the number of operations. Can you help him do it instead?A sequence of characters $$$a$$$ is a subsequence of a string $$$b$$$ if $$$a$$$ can be obtained from $$$b$$$ by deletion of several (possibly, zero or all) characters.

The only line of input contains a string $$$s$$$ ($$$1 \le |s| \le 1000$$$) formed by characters '(' and ')', where $$$|s|$$$ is the length of $$$s$$$.

In the first line, print an integer $$$k$$$  — the minimum number of operations you have to apply. Then, print $$$2k$$$ lines describing the operations in the following format: For each operation, print a line containing an integer $$$m$$$  — the number of characters in the subsequence you will remove. Then, print a line containing $$$m$$$ integers $$$1 \le a_1 < a_2 < \dots < a_m$$$  — the indices of the characters you will remove. All integers must be less than or equal to the length of the current string, and the corresponding subsequence must form a simple string. If there are multiple valid sequences of operations with the smallest $$$k$$$, you may print any of them.

NoteIn the first sample, the string is '(()(('. The operation described corresponds to deleting the bolded subsequence. The resulting string is '(((', and no more operations can be performed on it. Another valid answer is choosing indices $$$2$$$ and $$$3$$$, which results in the same final string.In the second sample, it is already impossible to perform any operations.

--import Control.Monad
--import Data.List
--import Data.Function

main :: IO ()
main = routine

routine :: IO ()
routine = do
  s <- getLine
  if end s
    then
      putStrLn "0"
    else
      do
        putStrLn "1"
        let
          answer = solve s
          in do
            print $ length answer
            putStrLn $ (unwords.map show) answer

solve :: String -> [Int]
solve s = take m offene ++ reverse (take m (reverse geschlossene))
  where
    zipped = zip s [(1::Int)..]
    offene = map snd $ filter (\(a,_) -> a=='(') zipped
    geschlossene = map snd $ filter (\(a,_) -> a==')') zipped
    s1 = scanl (\acc ch -> acc + fromEnum (ch == '(')) 0 s
    s2 = reverse $ scanr (\ch acc -> acc + fromEnum (ch == ')')) 0 s
    m = maximum $ zipWith min s1 (reverse s2)

end :: String -> Bool
end s = all (== '(') $ dropWhile (== ')') s

{-# LANGUAGE TypeFamilies, UndecidableInstances, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables #-}
import Data.Ord
import Data.Int
import Data.Char
import Data.Foldable
import Data.List
import Data.Maybe
import Data.Either
import Data.Array.ST.Safe
import Data.Array.Unboxed
import Control.Monad
import Control.Monad.ST.Safe
import Control.Monad.Trans.Except
import Control.Monad.Trans.Class
import Text.Read (readEither)

getToken :: IO String
getToken =
    let aux s = do
        x <- getChar
        if x == ' ' || x == '\t' || x == '\n' then
            if s then
                aux s
            else
                return id
        else
            liftM ((.) $ showChar x) $ aux False
    in liftM (flip ($) []) $ aux True

type EIO a = ExceptT String IO a

data HNormal
data HString
data HList

class IOInteract a where
    convertEither :: String -> Either String a
    toShowS :: a -> String -> String
    toShow :: a -> String
    toShow x = toShowS x []

instance (IOType a ~ flag, IOInteractp flag a) => IOInteract a where
    convertEither = convertEitherp (undefined :: flag)
    toShowS = toShowSp (undefined :: flag)

type family IOType x where
    IOType String = HString
    IOType [x] = HList
    IOType x = HNormal

class IOInteractp flag a where
    convertEitherp :: flag -> String -> Either String a
    toShowSp :: flag -> a -> String -> String

instance (Show a, Read a) => IOInteractp HNormal a where
    convertEitherp _ x = readEither x
    toShowSp _ x = shows x

instance IOInteractp HString String where
    convertEitherp _ x = Right x
    toShowSp _ x = showString x

instance (IOInteract a) => IOInteractp HList [a] where
    convertEitherp _ x = mapM convertEither $ words x
    toShowSp _ [] = id
    toShowSp _ (x : []) = toShowS x
    toShowSp dum (x : xs) = toShowS x . showChar ' ' . toShowSp dum xs

get :: IOInteract a => EIO a
get = ExceptT $ liftM convertEither getToken
put :: IOInteract a => a -> EIO ()
put = lift . putStr . toShow
putln :: IOInteract a => a -> EIO ()
putln = lift . putStrLn . toShow

main :: IO ()
main = do
    o <- runExceptT main_
    case o of
        Right () -> return ()
        Left s -> putStrLn s

main_ :: EIO ()
-- template --
main_ = do
    s <- get
    let k = f1 s in do
        putln $ length k
        f2 k

f1 :: String -> [(Int, [Int])]
f1 s = let sa = array (1, length s) (zip [1..length s] s) :: UArray Int Char in
       let ll = filter (\i -> sa ! i == '(') [1..length s] in
       let rl = filter (\i -> sa ! i == ')') $ reverse [1..length s] in
       let lrpair = filter (\(i, j) -> i < j) $ zip ll rl in
       let (newl, newr) = unzip lrpair in
       let newi =  (++) newl $ reverse newr in
       let (news, _) = foldl (\(s, l) i ->
            case l of
               x : xs -> if x == i then (s, xs) else ((sa ! i) : s, l)
               [] -> ((sa ! i) : s, [])
            ) ([], newi)  [1..length s] in
       if length newi == 0 then
           []
        else
           (length newi, newi) : (f1 $ reverse news)

f2 :: [(Int, [Int])] -> EIO ()
f2 [] = return ()
f2 ((k, l) : r) = do
    putln k
    putln l
    f2 r

--import Control.Monad
--import Data.List
--import Data.Function

main :: IO ()
main = routine

routine :: IO ()
routine = do
  s <- getLine
  if end s
    then
      putStrLn "0"
    else
      do
        putStrLn "1"
        let
          answer = solve s
          in do
            print $ length answer
            putStrLn $ (unwords.map show) answer

solve :: String -> [Int]
solve s = take m offene ++ take m (reverse geschlossene)
  where
    zipped = zip s [(1::Int)..]
    offene = map snd $ filter (\(a,_) -> a=='(') zipped
    geschlossene = map snd $ filter (\(a,_) -> a==')') zipped
    s1 = scanl (\acc ch -> acc + fromEnum (ch == '(')) 0 s
    s2 = reverse $ scanr (\ch acc -> acc + fromEnum (ch == ')')) 0 s
    m = maximum $ zipWith min s1 (reverse s2)

end :: String -> Bool
end s = all (== '(') $ dropWhile (== ')') s