Let's define a non-oriented connected graph of n vertices and n - 1 edges as a beard, if all of its vertices except, perhaps, one, have the degree of 2 or 1 (that is, there exists no more than one vertex, whose degree is more than two). Let us remind you that the degree of a vertex is the number of edges that connect to it. Let each edge be either black or white. Initially all edges are black.You are given the description of the beard graph. Your task is to analyze requests of the following types:   paint the edge number i black. The edge number i is the edge that has this number in the description. It is guaranteed that by the moment of this request the i-th edge is white  paint the edge number i white. It is guaranteed that by the moment of this request the i-th edge is black  find the length of the shortest path going only along the black edges between vertices a and b or indicate that no such path exists between them (a path's length is the number of edges in it) The vertices are numbered with integers from 1 to n, and the edges are numbered with integers from 1 to n - 1.

The first line of the input contains an integer n (2 ≤ n ≤ 105) — the number of vertices in the graph. Next n - 1 lines contain edges described as the numbers of vertices vi, ui (1 ≤ vi, ui ≤ n, vi ≠ ui) connected by this edge. It is guaranteed that the given graph is connected and forms a beard graph, and has no self-loops or multiple edges. The next line contains an integer m (1 ≤ m ≤ 3·105) — the number of requests. Next m lines contain requests in the following form: first a line contains an integer type, which takes values from 1 to 3, and represents the request type. If type = 1, then the current request is a request to paint the edge black. In this case, in addition to number type the line should contain integer id (1 ≤ id ≤ n - 1), which represents the number of the edge to paint. If type = 2, then the current request is a request to paint the edge white, its form is similar to the previous request. If type = 3, then the current request is a request to find the distance. In this case, in addition to type, the line should contain two integers a, b (1 ≤ a, b ≤ n, a can be equal to b) — the numbers of vertices, the distance between which must be found. The numbers in all lines are separated by exactly one space. The edges are numbered in the order in which they are given in the input.

For each request to "find the distance between vertices a and b" print the result. If there is no path going only along the black edges between vertices a and b, then print "-1" (without the quotes). Print the results in the order of receiving the requests, separate the numbers with spaces or line breaks.

NoteIn the first sample vertices 1 and 2 are connected with edge number 1, and vertices 2 and 3 are connected with edge number 2. Before the repainting edge number 2 each vertex is reachable from each one along the black edges. Specifically, the shortest path between 1 and 3 goes along both edges.If we paint edge number 2 white, vertex 3 will end up cut off from other vertices, that is, no path exists from it to any other vertex along the black edges.

{-# LANGUAGE BangPatterns, MagicHash #-}

import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Debug.Trace
import Data.Array
import Data.Array.ST
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Graph
import Data.List
import Data.Maybe
import Data.Tree
import Data.Tuple
import GHC.Prim
import GHC.Types

type Fenwick s = STUArray s Int Int
fenwick l = newArray (0, l-1) 0 :: ST s (Fenwick s)

update f i d = do
	l <- snd <$> getBounds f
	let next (I# i) = I# (i `orI#` (i +# 1#))
	-- let is = takeWhile (<= l) $ iterate (\i -> i .|. (i + 1)) i
	let is = takeWhile (<= l) $ iterate next i
	forM_ is $ \i -> do
		v <- readArray f i
		writeArray f i (v + d)
	return f

foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldM' _ z [] = return z
foldM' f z (x:xs) = do
  z' <- f z x
  z' `seq` foldM' f z' xs

a `andI#` b = word2Int# (int2Word# a `and#` int2Word# b)
a `orI#` b = word2Int# (int2Word# a `or#` int2Word# b)

query f (-1) = return 0
query f i = do
	-- let next i = (i .&. (i+1)) - 1
	let next (I# i) = I# ((i `andI#` (i +# 1#)) -# 1#)
	-- let next (I# i) = I# $ word2Int# $ (int2Word# i) or# (int2Word# i)
	-- sum <$> (mapM (readArray f) $ takeWhile (>= 0) $ iterate next i)
	foldM' (\s i -> (s+) <$> (readArray f i)) 0 $ takeWhile (>= 0) $ iterate next i
{-query f i = query1 f i 0

query1 f i r
	| i < 0 = return r
	| otherwise = do
		v <- readArray f i
		query1 f i' (r + v)
	where
		i' = i .&. (i + 1) - 1

query'' f !i
	| i < 0 = return 0
	| otherwise = do
		v <- readArray f i
		r <- query f i'
		return $ v + r
	where
		i' = i .&. (i + 1) - 1 -}

unordered edges = edges ++ map swap edges

solve n edges queries = runST $ do
		fenwicksList <- mapM (fenwick . length) paths

		let
			fenwicks = listArray (1, length paths) fenwicksList

		reverse <$> foldM (\rs q -> case q of
			[t, edgeIndex] -> do
				let
					(fenwicksIndex, index) = edgesPlaces edgeIndex
					fenwick = fenwicks ! fenwicksIndex
				update fenwick index (if t == 1 then -1 else 1)
				return rs
			[3, i, j] -> do
				let (i1, j1) = places ! i
				let (i2, j2) = places ! j
				s1 <- query (fenwicks ! i1) j1
				s2 <- query (fenwicks ! i2) j2

				let !d = if i1 == i2
                                        then if s1 == s2 then abs (j1 - j2) else -1
					else if s1 + s2 == 0 then j1 + j2 + 2 else -1
				return $ d : rs) [] queries

	where
		g = buildG (1, n) (unordered edges)
		root = fromMaybe 1 $ find (\i -> indegree g ! i > 2) [1..n]
		paths = map flatten $ subForest $ head $ dfs g [root]

		parents = accumArray (flip const) 0 (1, n) $ concat [path `zip` (root:path) | path <- paths]

		places = accumArray (flip const) (1, -1) (1, n) $
			[(vertex, (pathIndex, index)) | (path, pathIndex) <- paths `zip` [1..],
				(vertex, index) <- path `zip` [0..]]

		edges' = listArray (1, length edges) edges
		edgesPlaces edgeIndex = places ! k
			where
				(i, j) = edges' ! edgeIndex
				k = if parents ! i == j then i else j

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

main = do
	[n] <- readInts
	edges <- map (\[a, b] -> (a, b)) <$> replicateM (n - 1) readInts
	[m] <- readInts
	queries <- replicateM m readInts
	putStrLn $ unlines $ map show $ solve n edges queries

{-# LANGUAGE BangPatterns, MagicHash #-}
{-# OPTIONS_GHC -fvia-C -optc-O2 #-}
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Debug.Trace
import Data.Array
import Data.Array.ST
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Graph
import Data.List
import Data.Maybe
import Data.Tree
import Data.Tuple
import GHC.Prim
import GHC.Types

type Fenwick s = STUArray s Int Int
fenwick l = newArray (0, l-1) 0 :: ST s (Fenwick s)

update f i d = do
	l <- snd <$> getBounds f
	let next (I# i) = I# (i `orI#` (i +# 1#))
	-- let is = takeWhile (<= l) $ iterate (\i -> i .|. (i + 1)) i
	let is = takeWhile (<= l) $ iterate next i
	forM_ is $ \i -> do
		v <- readArray f i
		writeArray f i (v + d)
	return f

foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldM' _ z [] = return z
foldM' f z (x:xs) = do
  z' <- f z x
  z' `seq` foldM' f z' xs

a `andI#` b = word2Int# (int2Word# a `and#` int2Word# b)
a `orI#` b = word2Int# (int2Word# a `or#` int2Word# b)

query f (-1) = return 0
query f i = do
	-- let next i = (i .&. (i+1)) - 1
	let next (I# i) = I# ((i `andI#` (i +# 1#)) -# 1#)
	-- let next (I# i) = I# $ word2Int# $ (int2Word# i) or# (int2Word# i)
	-- sum <$> (mapM (readArray f) $ takeWhile (>= 0) $ iterate next i)
	foldM' (\s i -> (s+) <$> (readArray f i)) 0 $ takeWhile (>= 0) $ iterate next i
{-query f i = query1 f i 0

query1 f i r
	| i < 0 = return r
	| otherwise = do
		v <- readArray f i
		query1 f i' (r + v)
	where
		i' = i .&. (i + 1) - 1

query'' f !i
	| i < 0 = return 0
	| otherwise = do
		v <- readArray f i
		r <- query f i'
		return $ v + r
	where
		i' = i .&. (i + 1) - 1 -}

unordered edges = edges ++ map swap edges

solve n edges queries = runST $ do
		fenwicksList <- mapM (fenwick . length) paths

		let
			fenwicks = listArray (1, length paths) fenwicksList

		reverse <$> foldM (\rs q -> case q of
			[t, edgeIndex] -> do
				let
					(fenwicksIndex, index) = edgesPlaces edgeIndex
					fenwick = fenwicks ! fenwicksIndex
				update fenwick index (if t == 1 then -1 else 1)
				return rs
			[3, i, j] -> do
				let (i1, j1) = places ! i
				let (i2, j2) = places ! j
				s1 <- query (fenwicks ! i1) j1
				s2 <- query (fenwicks ! i2) j2

				let !d = if i1 == i2
                                        then if s1 == s2 then abs (j1 - j2) else -1
					else if s1 + s2 == 0 then j1 + j2 + 2 else -1
				return $ d : rs) [] queries

	where
		g = buildG (1, n) (unordered edges)
		root = fromMaybe 1 $ find (\i -> indegree g ! i > 2) [1..n]
		paths = map flatten $ subForest $ head $ dfs g [root]

		parents = accumArray (flip const) 0 (1, n) $ concat [path `zip` (root:path) | path <- paths]

		places = accumArray (flip const) (1, -1) (1, n) $
			[(vertex, (pathIndex, index)) | (path, pathIndex) <- paths `zip` [1..],
				(vertex, index) <- path `zip` [0..]]

		edges' = listArray (1, length edges) edges
		edgesPlaces edgeIndex = places ! k
			where
				(i, j) = edges' ! edgeIndex
				k = if parents ! i == j then i else j

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

main = do
	[n] <- readInts
	edges <- map (\[a, b] -> (a, b)) <$> replicateM (n - 1) readInts
	[m] <- readInts
	queries <- replicateM m readInts
	putStrLn $ unlines $ map show $ solve n edges queries

{-# LANGUAGE BangPatterns, MagicHash #-}
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Debug.Trace
import Data.Array
import Data.Array.ST
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Graph
import Data.List
import Data.Maybe
import Data.Tree
import Data.Tuple
import GHC.Prim
import GHC.Types

type Fenwick s = STUArray s Int Int
fenwick l = newArray (0, l-1) 0 :: ST s (Fenwick s)

update f i d = do
	l <- snd <$> getBounds f
	let is = takeWhile (<= l) $ iterate (\i -> i .|. (i + 1)) i
	forM_ is $ \i -> do
		v <- readArray f i
		writeArray f i (v + d)
	return f

foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldM' _ z [] = return z
foldM' f z (x:xs) = do
  z' <- f z x
  z' `seq` foldM' f z' xs

a `andI#` b = word2Int# (int2Word# a `and#` int2Word# b)
query f (-1) = return 0
query f i = do
	let next (I# i) = I# ((i `andI#` (i +# 1#)) -# 1#)
	-- let next (I# i) = I# $ word2Int# $ (int2Word# i) or# (int2Word# i)
	sum <$> (mapM (readArray f) $ takeWhile (>= 0) $ iterate next i)
	-- foldM' (\s i -> readArray f i) 0 $ takeWhile (>= 0) $ iterate next i
{-query f i = query1 f i 0

query1 f i r
	| i < 0 = return r
	| otherwise = do
		v <- readArray f i
		query1 f i' (r + v)
	where
		i' = i .&. (i + 1) - 1

query'' f !i
	| i < 0 = return 0
	| otherwise = do
		v <- readArray f i
		r <- query f i'
		return $ v + r
	where
		i' = i .&. (i + 1) - 1 -}

unordered edges = edges ++ map swap edges

solve n edges queries = runST $ do
		fenwicksList <- mapM (fenwick . length) paths

		let
			fenwicks = listArray (1, length paths) fenwicksList

		reverse <$> foldM (\rs q -> case q of
			[t, edgeIndex] -> do
				let
					(fenwicksIndex, index) = edgesPlaces edgeIndex
					fenwick = fenwicks ! fenwicksIndex
				update fenwick index (if t == 1 then -1 else 1)
				return rs
			[3, i, j] -> do
				let (i1, j1) = places ! i
				let (i2, j2) = places ! j
				s1 <- query (fenwicks ! i1) j1
				s2 <- query (fenwicks ! i2) j2

				let !d = if i1 == i2
                                        then if s1 == s2 then abs (j1 - j2) else -1
					else if s1 + s2 == 0 then j1 + j2 + 2 else -1
				return $ d : rs) [] queries

	where
		g = buildG (1, n) (unordered edges)
		root = fromMaybe 1 $ find (\i -> indegree g ! i > 2) [1..n]
		paths = map flatten $ subForest $ head $ dfs g [root]

		parents = accumArray (flip const) 0 (1, n) $ concat [path `zip` (root:path) | path <- paths]

		places = accumArray (flip const) (1, -1) (1, n) $
			[(vertex, (pathIndex, index)) | (path, pathIndex) <- paths `zip` [1..],
				(vertex, index) <- path `zip` [0..]]

		edges' = listArray (1, length edges) edges
		edgesPlaces edgeIndex = places ! k
			where
				(i, j) = edges' ! edgeIndex
				k = if parents ! i == j then i else j

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

main = do
	[n] <- readInts
	edges <- map (\[a, b] -> (a, b)) <$> replicateM (n - 1) readInts
	[m] <- readInts
	queries <- replicateM m readInts
	putStrLn $ unlines $ map show $ solve n edges queries

{-# LANGUAGE BangPatterns, MagicHash #-}
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Debug.Trace
import Data.Array
import Data.Array.ST
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Graph
import Data.List
import Data.Maybe
import Data.Tree
import Data.Tuple
import GHC.Prim
import GHC.Types

type Fenwick s = STUArray s Int Int
fenwick l = newArray (0, l-1) 0 :: ST s (Fenwick s)

update f i d = do
	l <- snd <$> getBounds f
	let is = takeWhile (<= l) $ iterate (\i -> i .|. (i + 1)) i
	forM_ is $ \i -> do
		v <- readArray f i
		writeArray f i (v + d)
	return f

foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldM' _ z [] = return z
foldM' f z (x:xs) = do
  z' <- f z x
  z' `seq` foldM' f z' xs

query f (-1) = return 0
query f i = do
	let next (I# i) = I# ((word2Int# ((int2Word# i) `and#` (int2Word# (i +# 1#)))) -# 1#)
	-- let next (I# i) = I# $ word2Int# $ (int2Word# i) or# (int2Word# i)
	sum <$> (mapM (readArray f) $ takeWhile (>= 0) $ iterate next i)
	-- foldM' (\!s !i -> readArray f i) 0 $ takeWhile (>= 0) $ iterate (\ !i -> i .&. (i + 1) - 1) i
{-query f i = query1 f i 0

query1 f i r
	| i < 0 = return r
	| otherwise = do
		v <- readArray f i
		query1 f i' (r + v)
	where
		i' = i .&. (i + 1) - 1

query'' f !i
	| i < 0 = return 0
	| otherwise = do
		v <- readArray f i
		r <- query f i'
		return $ v + r
	where
		i' = i .&. (i + 1) - 1 -}

unordered edges = edges ++ map swap edges

solve n edges queries = runST $ do
		fenwicksList <- mapM (fenwick . length) paths

		let
			fenwicks = listArray (1, length paths) fenwicksList

		reverse <$> foldM (\rs q -> case q of
			[t, edgeIndex] -> do
				let
					(fenwicksIndex, index) = edgesPlaces edgeIndex
					fenwick = fenwicks ! fenwicksIndex
				update fenwick index (if t == 1 then -1 else 1)
				return rs
			[3, i, j] -> do
				let (i1, j1) = places ! i
				let (i2, j2) = places ! j
				s1 <- query (fenwicks ! i1) j1
				s2 <- query (fenwicks ! i2) j2

				let !d = if i1 == i2
                                        then if s1 == s2 then abs (j1 - j2) else -1
					else if s1 + s2 == 0 then j1 + j2 + 2 else -1
				return $ d : rs) [] queries

	where
		g = buildG (1, n) (unordered edges)
		root = fromMaybe 1 $ find (\i -> indegree g ! i > 2) [1..n]
		paths = map flatten $ subForest $ head $ dfs g [root]

		parents = accumArray (flip const) 0 (1, n) $ concat [path `zip` (root:path) | path <- paths]

		places = accumArray (flip const) (1, -1) (1, n) $
			[(vertex, (pathIndex, index)) | (path, pathIndex) <- paths `zip` [1..],
				(vertex, index) <- path `zip` [0..]]

		edges' = listArray (1, length edges) edges
		edgesPlaces edgeIndex = places ! k
			where
				(i, j) = edges' ! edgeIndex
				k = if parents ! i == j then i else j

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

main = do
	[n] <- readInts
	edges <- map (\[a, b] -> (a, b)) <$> replicateM (n - 1) readInts
	[m] <- readInts
	queries <- replicateM m readInts
	putStrLn $ unlines $ map show $ solve n edges queries

{-# LANGUAGE BangPatterns, MagicHash #-}
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Debug.Trace
import Data.Array
import Data.Array.ST
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Graph
import Data.List
import Data.Maybe
import Data.Tree
import Data.Tuple
import GHC.Prim
import GHC.Types

type Fenwick s = STUArray s Int Int
fenwick l = newArray (0, l-1) 0 :: ST s (Fenwick s)

update f i d = do
	l <- snd <$> getBounds f
	let is = takeWhile (<= l) $ iterate (\i -> i .|. (i + 1)) i
	forM_ is $ \i -> do
		v <- readArray f i
		writeArray f i (v + d)
	return f

foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldM' _ z [] = return z
foldM' f z (x:xs) = do
  z' <- f z x
  z' `seq` foldM' f z' xs

a `andI#` b = word2Int# (int2Word# a `and#` int2Word# b)
query f (-1) = return 0
query f i = do
	let next (I# i) = I# ((i `andI#` (i +# 1#)) -# 1#)
	-- let next (I# i) = I# $ word2Int# $ (int2Word# i) or# (int2Word# i)
	-- sum <$> (mapM (readArray f) $ takeWhile (>= 0) $ iterate next i)
	foldM' (\s i -> (s+) <$> (readArray f i)) 0 $ takeWhile (>= 0) $ iterate next i
{-query f i = query1 f i 0

query1 f i r
	| i < 0 = return r
	| otherwise = do
		v <- readArray f i
		query1 f i' (r + v)
	where
		i' = i .&. (i + 1) - 1

query'' f !i
	| i < 0 = return 0
	| otherwise = do
		v <- readArray f i
		r <- query f i'
		return $ v + r
	where
		i' = i .&. (i + 1) - 1 -}

unordered edges = edges ++ map swap edges

solve n edges queries = runST $ do
		fenwicksList <- mapM (fenwick . length) paths

		let
			fenwicks = listArray (1, length paths) fenwicksList

		reverse <$> foldM (\rs q -> case q of
			[t, edgeIndex] -> do
				let
					(fenwicksIndex, index) = edgesPlaces edgeIndex
					fenwick = fenwicks ! fenwicksIndex
				update fenwick index (if t == 1 then -1 else 1)
				return rs
			[3, i, j] -> do
				let (i1, j1) = places ! i
				let (i2, j2) = places ! j
				s1 <- query (fenwicks ! i1) j1
				s2 <- query (fenwicks ! i2) j2

				let !d = if i1 == i2
                                        then if s1 == s2 then abs (j1 - j2) else -1
					else if s1 + s2 == 0 then j1 + j2 + 2 else -1
				return $ d : rs) [] queries

	where
		g = buildG (1, n) (unordered edges)
		root = fromMaybe 1 $ find (\i -> indegree g ! i > 2) [1..n]
		paths = map flatten $ subForest $ head $ dfs g [root]

		parents = accumArray (flip const) 0 (1, n) $ concat [path `zip` (root:path) | path <- paths]

		places = accumArray (flip const) (1, -1) (1, n) $
			[(vertex, (pathIndex, index)) | (path, pathIndex) <- paths `zip` [1..],
				(vertex, index) <- path `zip` [0..]]

		edges' = listArray (1, length edges) edges
		edgesPlaces edgeIndex = places ! k
			where
				(i, j) = edges' ! edgeIndex
				k = if parents ! i == j then i else j

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

main = do
	[n] <- readInts
	edges <- map (\[a, b] -> (a, b)) <$> replicateM (n - 1) readInts
	[m] <- readInts
	queries <- replicateM m readInts
	putStrLn $ unlines $ map show $ solve n edges queries

{-# LANGUAGE BangPatterns, MagicHash #-}
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Debug.Trace
import Data.Array
import Data.Array.ST
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Graph
import Data.List
import Data.Maybe
import Data.Tree
import Data.Tuple
import GHC.Prim
import GHC.Types

type Fenwick s = STUArray s Int Int
fenwick l = newArray (0, l-1) 0 :: ST s (Fenwick s)

update f i d = do
	l <- snd <$> getBounds f
	let is = takeWhile (<= l) $ iterate (\i -> i .|. (i + 1)) i
	forM_ is $ \i -> do
		v <- readArray f i
		writeArray f i (v + d)
	return f

foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldM' _ z [] = return z
foldM' f z (x:xs) = do
  z' <- f z x
  z' `seq` foldM' f z' xs

a `andI#` b = word2Int# (int2Word# a `and#` int2Word# b)
query f (-1) = return 0
query f i = do
	let next (I# i) = I# ((i `andI#` (i +# 1#)) -# 1#)
	-- let next (I# i) = I# $ word2Int# $ (int2Word# i) or# (int2Word# i)
	sum <$> (mapM (readArray f) $ takeWhile (>= 0) $ iterate next i)
	-- foldM' (\!s !i -> readArray f i) 0 $ takeWhile (>= 0) $ iterate (\ !i -> i .&. (i + 1) - 1) i
{-query f i = query1 f i 0

query1 f i r
	| i < 0 = return r
	| otherwise = do
		v <- readArray f i
		query1 f i' (r + v)
	where
		i' = i .&. (i + 1) - 1

query'' f !i
	| i < 0 = return 0
	| otherwise = do
		v <- readArray f i
		r <- query f i'
		return $ v + r
	where
		i' = i .&. (i + 1) - 1 -}

unordered edges = edges ++ map swap edges

solve n edges queries = runST $ do
		fenwicksList <- mapM (fenwick . length) paths

		let
			fenwicks = listArray (1, length paths) fenwicksList

		reverse <$> foldM (\rs q -> case q of
			[t, edgeIndex] -> do
				let
					(fenwicksIndex, index) = edgesPlaces edgeIndex
					fenwick = fenwicks ! fenwicksIndex
				update fenwick index (if t == 1 then -1 else 1)
				return rs
			[3, i, j] -> do
				let (i1, j1) = places ! i
				let (i2, j2) = places ! j
				s1 <- query (fenwicks ! i1) j1
				s2 <- query (fenwicks ! i2) j2

				let !d = if i1 == i2
                                        then if s1 == s2 then abs (j1 - j2) else -1
					else if s1 + s2 == 0 then j1 + j2 + 2 else -1
				return $ d : rs) [] queries

	where
		g = buildG (1, n) (unordered edges)
		root = fromMaybe 1 $ find (\i -> indegree g ! i > 2) [1..n]
		paths = map flatten $ subForest $ head $ dfs g [root]

		parents = accumArray (flip const) 0 (1, n) $ concat [path `zip` (root:path) | path <- paths]

		places = accumArray (flip const) (1, -1) (1, n) $
			[(vertex, (pathIndex, index)) | (path, pathIndex) <- paths `zip` [1..],
				(vertex, index) <- path `zip` [0..]]

		edges' = listArray (1, length edges) edges
		edgesPlaces edgeIndex = places ! k
			where
				(i, j) = edges' ! edgeIndex
				k = if parents ! i == j then i else j

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

main = do
	[n] <- readInts
	edges <- map (\[a, b] -> (a, b)) <$> replicateM (n - 1) readInts
	[m] <- readInts
	queries <- replicateM m readInts
	putStrLn $ unlines $ map show $ solve n edges queries

{-# LANGUAGE BangPatterns, MagicHash #-}
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Debug.Trace
import Data.Array
import Data.Array.ST
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Graph
import Data.List
import Data.Maybe
import Data.Tree
import Data.Tuple
import GHC.Prim
import GHC.Types

type Fenwick s = STUArray s Int Int
fenwick l = newArray (0, l-1) 0 :: ST s (Fenwick s)

update f i d = do
	l <- snd <$> getBounds f
	let next (I# i) = I# (i `orI#` (i +# 1#))
	-- let is = takeWhile (<= l) $ iterate (\i -> i .|. (i + 1)) i
	let is = takeWhile (<= l) $ iterate next i
	forM_ is $ \i -> do
		v <- readArray f i
		writeArray f i (v + d)
	return f

foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldM' _ z [] = return z
foldM' f z (x:xs) = do
  z' <- f z x
  z' `seq` foldM' f z' xs

a `andI#` b = word2Int# (int2Word# a `and#` int2Word# b)
a `orI#` b = word2Int# (int2Word# a `or#` int2Word# b)

query f (-1) = return 0
query f i = do
	let next (I# i) = I# ((i `andI#` (i +# 1#)) -# 1#)
	-- let next (I# i) = I# $ word2Int# $ (int2Word# i) or# (int2Word# i)
	-- sum <$> (mapM (readArray f) $ takeWhile (>= 0) $ iterate next i)
	foldM' (\s i -> (s+) <$> (readArray f i)) 0 $ takeWhile (>= 0) $ iterate next i
{-query f i = query1 f i 0

query1 f i r
	| i < 0 = return r
	| otherwise = do
		v <- readArray f i
		query1 f i' (r + v)
	where
		i' = i .&. (i + 1) - 1

query'' f !i
	| i < 0 = return 0
	| otherwise = do
		v <- readArray f i
		r <- query f i'
		return $ v + r
	where
		i' = i .&. (i + 1) - 1 -}

unordered edges = edges ++ map swap edges

solve n edges queries = runST $ do
		fenwicksList <- mapM (fenwick . length) paths

		let
			fenwicks = listArray (1, length paths) fenwicksList

		reverse <$> foldM (\rs q -> case q of
			[t, edgeIndex] -> do
				let
					(fenwicksIndex, index) = edgesPlaces edgeIndex
					fenwick = fenwicks ! fenwicksIndex
				update fenwick index (if t == 1 then -1 else 1)
				return rs
			[3, i, j] -> do
				let (i1, j1) = places ! i
				let (i2, j2) = places ! j
				s1 <- query (fenwicks ! i1) j1
				s2 <- query (fenwicks ! i2) j2

				let !d = if i1 == i2
                                        then if s1 == s2 then abs (j1 - j2) else -1
					else if s1 + s2 == 0 then j1 + j2 + 2 else -1
				return $ d : rs) [] queries

	where
		g = buildG (1, n) (unordered edges)
		root = fromMaybe 1 $ find (\i -> indegree g ! i > 2) [1..n]
		paths = map flatten $ subForest $ head $ dfs g [root]

		parents = accumArray (flip const) 0 (1, n) $ concat [path `zip` (root:path) | path <- paths]

		places = accumArray (flip const) (1, -1) (1, n) $
			[(vertex, (pathIndex, index)) | (path, pathIndex) <- paths `zip` [1..],
				(vertex, index) <- path `zip` [0..]]

		edges' = listArray (1, length edges) edges
		edgesPlaces edgeIndex = places ! k
			where
				(i, j) = edges' ! edgeIndex
				k = if parents ! i == j then i else j

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

main = do
	[n] <- readInts
	edges <- map (\[a, b] -> (a, b)) <$> replicateM (n - 1) readInts
	[m] <- readInts
	queries <- replicateM m readInts
	putStrLn $ unlines $ map show $ solve n edges queries

import Data.Graph
import Data.Maybe (fromJust)
import Control.Applicative ((<$>))
import Control.Monad (replicateM)
import Data.ByteString (getLine, getContents)
import Data.ByteString.Char8 (readInt, words, lines)
import Prelude hiding (getLine, words, lines)

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

solve n edges queries = "ok"

main = do
	[n] <- readInts
	edges <- map (\[a, b] -> (a, b)) <$> replicateM (n - 1) readInts
	[m] <- readInts
	queries <- replicateM m readInts
	putStrLn $ unlines $ map show $ solve n edges queries

{-# LANGUAGE BangPatterns, MagicHash #-}
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Debug.Trace
import Data.Array
import Data.Array.ST
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Graph
import Data.List
import Data.Maybe
import Data.Tree
import Data.Tuple
import GHC.Prim
import GHC.Types

type Fenwick s = STUArray s Int Int
fenwick l = newArray (0, l-1) 0 :: ST s (Fenwick s)

update f i d = do
	l <- snd <$> getBounds f
	let is = takeWhile (<= l) $ iterate (\i -> i .|. (i + 1)) i
	forM_ is $ \i -> do
		v <- readArray f i
		writeArray f i (v + d)
	return f

foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldM' _ z [] = return z
foldM' f z (x:xs) = do
  z' <- f z x
  z' `seq` foldM' f z' xs

a `andI#` b = word2Int# (int2Word# a `and#` int2Word# b)
query f (-1) = return 0
query f i = do
	let next (I# i) = I# ((i `andI#` (i +# 1#)) -# 1#)
	-- let next (I# i) = I# $ word2Int# $ (int2Word# i) or# (int2Word# i)
	-- sum <$> (mapM (readArray f) $ takeWhile (>= 0) $ iterate next i)
	foldM' (\s i -> readArray f i) 0 $ takeWhile (>= 0) $ iterate next i
{-query f i = query1 f i 0

query1 f i r
	| i < 0 = return r
	| otherwise = do
		v <- readArray f i
		query1 f i' (r + v)
	where
		i' = i .&. (i + 1) - 1

query'' f !i
	| i < 0 = return 0
	| otherwise = do
		v <- readArray f i
		r <- query f i'
		return $ v + r
	where
		i' = i .&. (i + 1) - 1 -}

unordered edges = edges ++ map swap edges

solve n edges queries = runST $ do
		fenwicksList <- mapM (fenwick . length) paths

		let
			fenwicks = listArray (1, length paths) fenwicksList

		reverse <$> foldM (\rs q -> case q of
			[t, edgeIndex] -> do
				let
					(fenwicksIndex, index) = edgesPlaces edgeIndex
					fenwick = fenwicks ! fenwicksIndex
				update fenwick index (if t == 1 then -1 else 1)
				return rs
			[3, i, j] -> do
				let (i1, j1) = places ! i
				let (i2, j2) = places ! j
				s1 <- query (fenwicks ! i1) j1
				s2 <- query (fenwicks ! i2) j2

				let !d = if i1 == i2
                                        then if s1 == s2 then abs (j1 - j2) else -1
					else if s1 + s2 == 0 then j1 + j2 + 2 else -1
				return $ d : rs) [] queries

	where
		g = buildG (1, n) (unordered edges)
		root = fromMaybe 1 $ find (\i -> indegree g ! i > 2) [1..n]
		paths = map flatten $ subForest $ head $ dfs g [root]

		parents = accumArray (flip const) 0 (1, n) $ concat [path `zip` (root:path) | path <- paths]

		places = accumArray (flip const) (1, -1) (1, n) $
			[(vertex, (pathIndex, index)) | (path, pathIndex) <- paths `zip` [1..],
				(vertex, index) <- path `zip` [0..]]

		edges' = listArray (1, length edges) edges
		edgesPlaces edgeIndex = places ! k
			where
				(i, j) = edges' ! edgeIndex
				k = if parents ! i == j then i else j

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

main = do
	[n] <- readInts
	edges <- map (\[a, b] -> (a, b)) <$> replicateM (n - 1) readInts
	[m] <- readInts
	queries <- replicateM m readInts
	putStrLn $ unlines $ map show $ solve n edges queries

import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Debug.Trace
import Data.Array
import Data.Array.ST
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Graph
import Data.List
import Data.Maybe
import Data.Tree
import Data.Tuple

type Fenwick s = STUArray s Int Int
fenwick l = newArray (0, l-1) 0 :: ST s (Fenwick s)

update f i d = do
	l <- snd <$> getBounds f
	let is = takeWhile (<= l) $ iterate (\i -> i .|. (i + 1)) i
	forM_ is $ \i -> do
		v <- readArray f i
		writeArray f i (v + d)
	return f

query f (-1) = return 0
query f i = do
	let is = takeWhile (>= 0) $ iterate (\i -> i .&. (i + 1) - 1) i
	vs <- mapM (readArray f) is
	return $ sum vs

unordered edges = edges ++ map swap edges

solve n edges queries = runST $ do
		fenwicksList <- mapM (fenwick . length) paths

		let
			fenwicks = listArray (1, length paths) fenwicksList

		foldM (\rs q -> case q of
			[t, edgeIndex] -> do
				let
					(fenwicksIndex, index) = edgesPlaces edgeIndex
					fenwick = fenwicks ! fenwicksIndex
				update fenwick index (if t == 1 then -1 else 1)
				return rs
			[3, i, j] -> do
				let (i1, j1) = places ! i
				let (i2, j2) = places ! j
				s1 <- query (fenwicks ! i1) j1
				s2 <- query (fenwicks ! i2) j2

				let d = if i1 == i2
                                        then if s1 == s2 then abs (j1 - j2) else -1
					else if s1 + s2 == 0 then j1 + j2 + 2 else -1
				return $ d : rs) [] queries

	where
		g = buildG (1, n) (unordered edges)
		root = fromMaybe 1 $ find (\i -> indegree g ! i > 2) [1..n]
		paths = map flatten $ subForest $ head $ dfs g [root]

		parents = accumArray (flip const) 0 (1, n) $ concat [path `zip` (root:path) | path <- paths]

		places = accumArray (flip const) (1, -1) (1, n) $
			[(vertex, (pathIndex, index)) | (path, pathIndex) <- paths `zip` [1..],
				(vertex, index) <- path `zip` [0..]]

		edges' = listArray (1, length edges) edges
		edgesPlaces edgeIndex = places ! k
			where
				(i, j) = edges' ! edgeIndex
				k = if parents ! i == j then i else j

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

main = do
	[n] <- readInts
	edges <- map (\[a, b] -> (a, b)) <$> replicateM (n - 1) readInts
	[m] <- readInts
	queries <- replicateM m readInts
	putStrLn $ unlines $ map show $ solve n edges queries


Recently in school Alina has learned what are the persistent data structures: they are data structures that always preserves the previous version of itself and access to it when it is modified.After reaching home Alina decided to invent her own persistent data structure. Inventing didn't take long: there is a bookcase right behind her bed. Alina thinks that the bookcase is a good choice for a persistent data structure. Initially the bookcase is empty, thus there is no book at any position at any shelf.The bookcase consists of n shelves, and each shelf has exactly m positions for books at it. Alina enumerates shelves by integers from 1 to n and positions at shelves — from 1 to m. Initially the bookcase is empty, thus there is no book at any position at any shelf in it.Alina wrote down q operations, which will be consecutively applied to the bookcase. Each of the operations has one of four types: 1 i j — Place a book at position j at shelf i if there is no book at it. 2 i j — Remove the book from position j at shelf i if there is a book at it. 3 i — Invert book placing at shelf i. This means that from every position at shelf i which has a book at it, the book should be removed, and at every position at shelf i which has not book at it, a book should be placed. 4 k — Return the books in the bookcase in a state they were after applying k-th operation. In particular, k = 0 means that the bookcase should be in initial state, thus every book in the bookcase should be removed from its position.After applying each of operation Alina is interested in the number of books in the bookcase. Alina got 'A' in the school and had no problem finding this values. Will you do so?

The first line of the input contains three integers n, m and q (1 ≤ n, m ≤ 103, 1 ≤ q ≤ 105) — the bookcase dimensions and the number of operations respectively. The next q lines describes operations in chronological order — i-th of them describes i-th operation in one of the four formats described in the statement. It is guaranteed that shelf indices and position indices are correct, and in each of fourth-type operation the number k corresponds to some operation before it or equals to 0.

For each operation, print the number of books in the bookcase after applying it in a separate line. The answers should be printed in chronological order.

NoteThis image illustrates the second sample case.

{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import Control.Monad
import qualified Data.Sequence as Seq
import Data.Foldable (toList)

main = do
  [n, m, q] <- map read . words <$> getLine
  qs <- replicateM q (map read . words <$> getLine)

  let
    process bookcases [1, i, j] = bookcases Seq.|> bookcase'
      where
        _ Seq.:> (total, shelves) = Seq.viewr bookcases
        (cnt, mark, books) = shelves `Seq.index` (i-1)
        pres = books `Seq.index` (j-1)

        books'
          | pres /= mark = Seq.update (j-1) mark books
          | otherwise = books

        d = if pres == mark then 0 else 1

        shelves' = Seq.update (i-1) (cnt+d, mark, books') shelves
        bookcase' = (total+d, shelves')

    process bookcases [2, i, j] = bookcases Seq.|> bookcase'
      where
        _ Seq.:> (total, shelves) = Seq.viewr bookcases
        (cnt, mark, books) = shelves `Seq.index` (i-1)
        pres = books `Seq.index` (j-1)

        books'
          | pres /= not mark = Seq.update (j-1) (not mark) books
          | otherwise = books

        d = if pres == not mark then 0 else -1

        shelves' = Seq.update (i-1) (cnt+d, mark, books') shelves
        bookcase' = (total+d, shelves')

    process bookcases [3, i] = bookcases Seq.|> bookcase'
      where
        _ Seq.:> (total, shelves) = Seq.viewr bookcases
        (cnt, mark, books) = shelves `Seq.index` (i-1)

        d = -cnt + m-cnt

        shelves' = Seq.update (i-1) (cnt+d, not mark, books) shelves
        bookcase' = (total+d, shelves')

    process bookcases [4, k] = bookcases Seq.|> bookcase'
      where
        bookcase' = bookcases `Seq.index` k

    zero = (0, Seq.replicate n zero') where zero' = (0, True, Seq.replicate m False)

    bookcases = foldl process (Seq.singleton zero) qs

  -- putStr $ unlines $ map show $ toList bookcases

  putStr $ unlines $ map show $ map fst $ tail $ toList bookcases

import Control.Applicative
import Control.Monad
import Data.IORef
import Data.Array.IO.Safe
import qualified Data.Set

data Tree = Nil | Inner Tree Tree Int | Leaf (Data.Set.Set Int) Bool deriving Show

treeWidth = 2 ^ 10

makeInner :: Int -> Tree -> Tree -> Tree
makeInner w l r = Inner l r (getSum w l + getSum w r)

getSum :: Int -> Tree -> Int
getSum _ Nil = 0
getSum _ (Inner _ _ s) = s
getSum w (Leaf s rev) = let sz = Data.Set.size s in if rev then w - sz else sz

update :: Int -> Int -> Int -> Int -> Int -> Int -> Tree -> Tree
update w t y x a b Nil = update w t y x a b tr
	where tr = if b - a == 1 then Leaf Data.Set.empty False else Inner Nil Nil 0

update w t y x a b (Inner l r _) =
	if y < mid then makeInner w (update w t y x a mid l) r
	else makeInner w l (update w t y x mid b r)
	where mid = (a + b) `div` 2

update w t y x a b (Leaf s rev) =
	case t of
		1 -> Leaf ((if rev then Data.Set.delete else Data.Set.insert) x s) rev
		2 -> Leaf ((if rev then Data.Set.insert else Data.Set.delete) x s) rev
		3 -> Leaf s (not rev)

main = do
	[h, w, q] <- map read . words <$> getLine :: IO [Int]
	queries <- map (map read . words) <$> replicateM q getLine :: IO [[Int]]

	history <- newArray (0, q) Nil :: IO (IOArray Int Tree)
	tree <- newIORef Nil :: IO (IORef Tree)

	forM_ (zip [0..] queries) $ \(i, q) -> do
		t <- readIORef tree
		writeArray history i t
		when (head q == 1) $ do
			let [k, y, x] = q
			writeIORef tree $ update w k (y - 1) (x - 1) 0 treeWidth t
		when (head q == 2) $ do
			let [k, y, x] = q
			writeIORef tree $ update w k (y - 1) (x - 1) 0 treeWidth t
		when (head q == 3) $ do
			let [k, y] = q
			writeIORef tree $ update w k (y - 1) 0 0 treeWidth t
		when (head q == 4) $ do
			let [k, y] = q
			nextTree <- readArray history y
			writeIORef tree nextTree
		currTree <- readIORef tree
		print $ getSum w currTree

{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import Control.Monad
import qualified Data.Sequence as Seq
import Data.Foldable (toList)

main = do
  [n, m, q] <- map read . words <$> getLine
  qs <- replicateM q (map read . words <$> getLine)

  let
    process bookcases [1, i, j] = bookcases Seq.|> bookcase'
      where
        _ Seq.:> (total, shelves) = Seq.viewr bookcases
        (cnt, mark, books) = shelves `Seq.index` (i-1)
        pres = books `Seq.index` (j-1)

        books'
          | pres /= mark = Seq.update (j-1) mark books
          | otherwise = books

        d
          | pres == mark = 0
          | mark = 1
          | otherwise = -1

        shelves' = Seq.update (i-1) (cnt+d, mark, books') shelves
        bookcase' = (total+d, shelves')

    process bookcases [2, i, j] = bookcases Seq.|> bookcase'
      where
        _ Seq.:> (total, shelves) = Seq.viewr bookcases
        (cnt, mark, books) = shelves `Seq.index` (i-1)
        pres = books `Seq.index` (j-1)

        books'
          | pres /= not mark = Seq.update (j-1) mark books
          | otherwise = books

        d
          | pres == not mark = 0
          | not mark = -1
          | otherwise = 1

        shelves' = Seq.update i (cnt+d, mark, books') shelves
        bookcase' = (total+d, shelves')

    process bookcases [3, i] = bookcases Seq.|> bookcase'
      where
        _ Seq.:> (total, shelves) = Seq.viewr bookcases
        (cnt, mark, books) = shelves `Seq.index` (i-1)

        d = -cnt + m-cnt

        shelves' = Seq.update (i-1) (cnt+d, not mark, books) shelves
        bookcase' = (total+d, shelves')

    process bookcases [4, k] = bookcases Seq.|> bookcase'
      where
        bookcase' = bookcases `Seq.index` k

    zero = (0, Seq.replicate n zero') where zero' = (0, True, Seq.replicate m False)

    bookcases = foldl process (Seq.singleton zero) qs

  putStr $ unlines $ map show $ map fst $ tail $ toList bookcases

{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import Control.Monad
import qualified Data.Sequence as Seq
import Data.Foldable (toList)

main = do
  [n, m, q] <- map read . words <$> getLine
  qs <- replicateM q (map read . words <$> getLine)

  let
    process bookcases [1, i, j] = bookcases Seq.|> bookcase'
      where
        _ Seq.:> (total, shelves) = Seq.viewr bookcases
        (cnt, mark, books) = shelves `Seq.index` (i-1)
        pres = books `Seq.index` (j-1)

        books'
          | pres /= mark = Seq.update (j-1) mark books
          | otherwise = books

        d
          | pres == mark = 0
          | mark = 1
          | otherwise = -1

        shelves' = Seq.update (i-1) (cnt+d, mark, books') shelves
        bookcase' = (total+d, shelves')

    process bookcases [2, i, j] = bookcases Seq.|> bookcase'
      where
        _ Seq.:> (total, shelves) = Seq.viewr bookcases
        (cnt, mark, books) = shelves `Seq.index` (i-1)
        pres = books `Seq.index` (j-1)

        books'
          | pres /= not mark = Seq.update (j-1) (not mark) books
          | otherwise = books

        d
          | pres == not mark = 0
          | not mark = -1
          | otherwise = 1

        shelves' = Seq.update (i-1) (cnt+d, mark, books') shelves
        bookcase' = (total+d, shelves')

    process bookcases [3, i] = bookcases Seq.|> bookcase'
      where
        _ Seq.:> (total, shelves) = Seq.viewr bookcases
        (cnt, mark, books) = shelves `Seq.index` (i-1)

        d = -cnt + m-cnt

        shelves' = Seq.update (i-1) (cnt+d, not mark, books) shelves
        bookcase' = (total+d, shelves')

    process bookcases [4, k] = bookcases Seq.|> bookcase'
      where
        bookcase' = bookcases `Seq.index` k

    zero = (0, Seq.replicate n zero') where zero' = (0, True, Seq.replicate m False)

    bookcases = foldl process (Seq.singleton zero) qs

  -- putStr $ unlines $ map show $ toList bookcases

  putStr $ unlines $ map show $ map fst $ tail $ toList bookcases


You've got an n × m pixel picture. Each pixel can be white or black. Your task is to change the colors of as few pixels as possible to obtain a barcode picture.A picture is a barcode if the following conditions are fulfilled:   All pixels in each column are of the same color.  The width of each monochrome vertical line is at least x and at most y pixels. In other words, if we group all neighbouring columns of the pixels with equal color, the size of each group can not be less than x or greater than y.

The first line contains four space-separated integers n, m, x and y (1 ≤ n, m, x, y ≤ 1000; x ≤ y). Then follow n lines, describing the original image. Each of these lines contains exactly m characters. Character "." represents a white pixel and "#" represents a black pixel. The picture description doesn't have any other characters besides "." and "#".

In the first line print the minimum number of pixels to repaint. It is guaranteed that the answer exists.

NoteIn the first test sample the picture after changing some colors can looks as follows:  .##...##...##...##...##...##.. In the second test sample the picture after changing some colors can looks as follows:  .#.#..#.#.

import Control.Arrow
import Data.List
cnt f=length.filter f
est=cnt(=='.')&&&cnt(=='#')
s(hl:rl)=ss(map read.words$hl)(map est $ transpose rl)
ss[_,_,x,y]=go(0 : replicate y 9999999,0 : replicate y 9999999) where
  go(sharps, dots)((needToSharp,needToDot):needs) = ans where
    zsharps = minimum (drop x rdots)
    zdots = minimum (drop x rsharps)
    rdots = zdots : map (needToDot+) (init dots)
    rsharps = zsharps : map (needToSharp+) (init sharps)
    ans = go (rsharps, rdots) needs
  go(sharps, dots)[] = minimum $ drop x sharps ++ drop x dots
main=interact$show.s.lines


Seiji Maki doesn't only like to observe relationships being unfolded, he also likes to observe sequences of numbers, especially permutations. Today, he has his eyes on almost sorted permutations.A permutation $$$a_1, a_2, \dots, a_n$$$ of $$$1, 2, \dots, n$$$ is said to be almost sorted if the condition $$$a_{i + 1} \ge a_i - 1$$$ holds for all $$$i$$$ between $$$1$$$ and $$$n - 1$$$ inclusive.Maki is considering the list of all almost sorted permutations of $$$1, 2, \dots, n$$$, given in lexicographical order, and he wants to find the $$$k$$$-th permutation in this list. Can you help him to find such permutation?Permutation $$$p$$$ is lexicographically smaller than a permutation $$$q$$$ if and only if the following holds: in the first position where $$$p$$$ and $$$q$$$ differ, the permutation $$$p$$$ has a smaller element than the corresponding element in $$$q$$$.

The first line contains a single integer $$$t$$$ ($$$1\le t\le 1000$$$) — the number of test cases. Each test case consists of a single line containing two integers $$$n$$$ and $$$k$$$ ($$$1 \le n \le 10^5$$$, $$$1 \le k \le 10^{18}$$$). It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$10^5$$$.

For each test case, print a single line containing the $$$k$$$-th almost sorted permutation of length $$$n$$$ in lexicographical order, or $$$-1$$$ if it doesn't exist.

NoteFor the first and second test, the list of almost sorted permutations with $$$n = 1$$$ is $$$\{[1]\}$$$.For the third and fifth test, the list of almost sorted permutations with $$$n = 3$$$ is $$$\{[1, 2, 3], [1, 3, 2], [2, 1, 3], [3, 2, 1]\}$$$.

{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict              #-}

import           Control.Arrow              ((>>>))
import           Control.Monad              (MonadPlus (mplus), foldM_, forM_,
                                             guard, join, replicateM,
                                             replicateM_)
import qualified Control.Monad.ST.Strict    as ST
import qualified Control.Monad.State.Strict as S
import qualified Data.Array                 as A
import qualified Data.Array.MArray.Safe     as MA
import qualified Data.Array.ST.Safe         as STA
import qualified Data.Array.Unboxed         as UA
import           Data.Bits
import qualified Data.ByteString.Char8      as B8
import           Data.Char
import           Data.Function              (on)
import           Data.Functor               ((<&>))
import           Data.IORef                 (modifyIORef, newIORef, readIORef)
import           Data.Int
import qualified Data.IntMap                as IM
import           Data.List                  (elemIndices, find, findIndices,
                                             intersect, isPrefixOf, nub, sort,
                                             sortOn)
import qualified Data.Map                   as M
import           Data.Maybe                 (fromJust, fromMaybe, isJust)
import qualified Data.Set                   as S
import           Data.Traversable           (forM)
import           System.IO                  (IOMode (ReadMode, WriteMode),
                                             hFlush, openFile, stdin, stdout)
import           Text.Printf                (printf)

import           Debug.Trace                (trace, traceM, traceShowM)

debug :: c -> String -> c
debug = flip trace
traced x = trace (show x) x
withTrace s x = trace (s ++ " -> " ++ show x) x

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

readIntegerB8 :: B8.ByteString -> Integer
readIntegerB8 = B8.readInteger >>> (fst . fromJust)

solve :: Int -> Int64 -> Maybe [Int]
solve n k =
        solve' 1 [] k
    where
        solve' :: Int -> [Int] -> Int64 -> Maybe [Int]
        solve' i is k
            | i == n + 1          = if k <= 0 && null is then Just [] else Nothing
            | k >= kCount         = solve' (i + 1) (i : is) (k - kCount)
            | otherwise           = ((i : is) ++) <$> solve' (i + 1) [] k
            where
                kCount = count' (n - i - 1)

        count' :: Int -> Int64
        count' x
            | x < 0       = 1
            | x >= 61     = 2 ^ 61
            | otherwise   = 2 ^ fromIntegral x

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    forM_ [1..t] $ \_ -> do
        [n, k] :: [Int64] <- B8.getLine <&> B8.words <&> map (fromInteger . readIntegerB8)
        let answer = solve (fromIntegral n) (k - 1)
        case answer of
            Just answer -> forM_ answer $ printf "%lld "
            Nothing -> printf "-1"
        printf "\n"

import Control.Monad
import Data.Maybe
import Data.Int
import qualified Data.ByteString.Char8 as C

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

parseInt64 :: C.ByteString -> Int64
parseInt64 = fromIntegral . fst . fromJust . C.readInteger

func :: Int -> Int -> Int64 -> [Int]
func n i k
  | n >= 63 = i : func (n - 1) (i + 1) k
  | n <= 0 = []
  | otherwise = [i + j - 1, i + j - 2 .. i] ++ func (n - j) (i + j) (k - limit + 1)
  where
  limits = iterate (\(lim, j) -> (lim + 2 ^ (max 0 (n - 1 - j)), j + 1)) (1 :: Int64, 1 :: Int)
  (limit, j) = last $ takeWhile (\(lim, _) -> k >= lim) limits

main :: IO ()
main = do
  t <- fmap parseInt C.getLine
  replicateM_ t $ do
    [s1, s2] <- fmap C.words C.getLine
    let n = parseInt s1
        k = parseInt64 s2
    C.putStrLn $ C.pack $ if n < 63 && k > 2 ^ (n - 1)
                            then "-1"
                            else unwords $ map show $ func n 1 k


There was a big bank robbery in Tablecity. In order to catch the thief, the President called none other than Albert – Tablecity’s Chief of Police. Albert does not know where the thief is located, but he does know how he moves.Tablecity can be represented as 1000 × 2 grid, where every cell represents one district. Each district has its own unique name “(X, Y)”, where X and Y are the coordinates of the district in the grid. The thief’s movement is as Every hour the thief will leave the district (X, Y) he is currently hiding in, and move to one of the districts: (X - 1, Y), (X + 1, Y), (X - 1, Y - 1), (X - 1, Y + 1), (X + 1, Y - 1), (X + 1, Y + 1) as long as it exists in Tablecity. Below is an example of thief’s possible movements if he is located in district (7,1):Albert has enough people so that every hour he can pick any two districts in Tablecity and fully investigate them, making sure that if the thief is located in one of them, he will get caught. Albert promised the President that the thief will be caught in no more than 2015 hours and needs your help in order to achieve that.

The first line of output contains integer N – duration of police search in hours. Each of the following N lines contains exactly 4 integers Xi1, Yi1, Xi2, Yi2 separated by spaces, that represent 2 districts (Xi1, Yi1), (Xi2, Yi2) which got investigated during i-th hour. Output is given in chronological order (i-th line contains districts investigated during i-th hour) and should guarantee that the thief is caught in no more than 2015 hours, regardless of thief’s initial position and movement.   N ≤ 2015  1 ≤ X ≤ 1000  1 ≤ Y ≤ 2

В этой задаче нет примеров ввода-вывода.
This problem doesn't have sample input and output.

Смотрите замечание ниже.
See the note below.

NoteLet's consider the following output:25 1 50 28 1 80 2This output is not guaranteed to catch the thief and is not correct. It is given to you only to show the expected output format. There exists a combination of an initial position and a movement strategy such that the police will not catch the thief.Consider the following initial position and thief’s movement:In the first hour, the thief is located in district (1,1). Police officers will search districts (5,1) and (50,2) and will not find him.At the start of the second hour, the thief moves to district (2,2). Police officers will search districts (8,1) and (80,2) and will not find him.Since there is no further investigation by the police, the thief escaped!

import Data.List (intersperse)

formatList :: Show a => [a] -> String
formatList = concat . intersperse " " . map show

main :: IO [()]
main = do
    let n = 1000
        a = map (\x -> [x, 1, x, 2]) [1 .. n]
    print (n * 2)
    mapM (putStrLn . formatList) (a ++ reverse a)

module Main where

str n = putStrLn (show n ++ " 1 " ++ show n ++ " 2")

main = print 2001 >> mapM_ str [1..1000] >> str 1 >> mapM_ str [1..1000]

import Data.List (intersperse)

formatList :: Show a => [a] -> String
formatList = concat . intersperse " " . map show

main :: IO [()]
main = do
    let n = 1000
        a = map (\x -> [x, 1, x, 2]) [1 .. n]
    print n
    mapM (putStrLn . formatList) (a ++ reverse a)

import Data.List (intersperse)

formatList :: Show a => [a] -> String
formatList = concat . intersperse " " . map show

main :: IO [()]
main = do
    let n = 1000
        a = map (\x -> [x, 1, x, 2]) [1 .. n]
    mapM (putStrLn . formatList) (a ++ reverse a)

module Main where

str n = putStrLn (show n ++ " 1 " ++ show n ++ " 2")

rez 0 = return ()
rez n = str n >> str n >> rez (n - 1)

main = print 2000 >> rez 1000

module Main where

str n = putStrLn (show n ++ " 1 " ++ show n ++ " 2")

rez 0 = return ()
rez n = str n >> str n >> rez (n - 2)

main = print 2000 >> rez 2000


Mr. Apple, a gourmet, works as editor-in-chief of a gastronomic periodical. He travels around the world, tasting new delights of famous chefs from the most fashionable restaurants. Mr. Apple has his own signature method of review  — in each restaurant Mr. Apple orders two sets of dishes on two different days. All the dishes are different, because Mr. Apple doesn't like to eat the same food. For each pair of dishes from different days he remembers exactly which was better, or that they were of the same quality. After this the gourmet evaluates each dish with a positive integer.Once, during a revision of a restaurant of Celtic medieval cuisine named «Poisson», that serves chestnut soup with fir, warm soda bread, spicy lemon pie and other folk food, Mr. Apple was very pleasantly surprised the gourmet with its variety of menu, and hence ordered too much. Now he's confused about evaluating dishes.The gourmet tasted a set of $$$n$$$ dishes on the first day and a set of $$$m$$$ dishes on the second day. He made a table $$$a$$$ of size $$$n \times m$$$, in which he described his impressions. If, according to the expert, dish $$$i$$$ from the first set was better than dish $$$j$$$ from the second set, then $$$a_{ij}$$$ is equal to ">", in the opposite case $$$a_{ij}$$$ is equal to "<". Dishes also may be equally good, in this case $$$a_{ij}$$$ is "=".Now Mr. Apple wants you to help him to evaluate every dish. Since Mr. Apple is very strict, he will evaluate the dishes so that the maximal number used is as small as possible. But Mr. Apple also is very fair, so he never evaluates the dishes so that it goes against his feelings. In other words, if $$$a_{ij}$$$ is "<", then the number assigned to dish $$$i$$$ from the first set should be less than the number of dish $$$j$$$ from the second set, if $$$a_{ij}$$$ is ">", then it should be greater, and finally if $$$a_{ij}$$$ is "=", then the numbers should be the same.Help Mr. Apple to evaluate each dish from both sets so that it is consistent with his feelings, or determine that this is impossible.

The first line contains integers $$$n$$$ and $$$m$$$ ($$$1 \leq n, m \leq 1000$$$) — the number of dishes in both days. Each of the next $$$n$$$ lines contains a string of $$$m$$$ symbols. The $$$j$$$-th symbol on $$$i$$$-th line is $$$a_{ij}$$$. All strings consist only of "<", ">" and "=".

The first line of output should contain "Yes", if it's possible to do a correct evaluation for all the dishes, or "No" otherwise. If case an answer exist, on the second line print $$$n$$$ integers — evaluations of dishes from the first set, and on the third line print $$$m$$$ integers — evaluations of dishes from the second set.

NoteIn the first sample, all dishes of the first day are better than dishes of the second day. So, the highest score will be $$$2$$$, for all dishes of the first day.In the third sample, the table is contradictory — there is no possible evaluation of the dishes that satisfies it.

{-# LANGUAGE BangPatterns #-}
import Control.Monad
import qualified Data.ByteString.Char8 as B

import Data.Maybe
import Data.List(partition)
import Data.Array.IO.Safe
import Data.Array.IArray
import Data.Array.MArray.Safe
import Data.Graph
import Data.Foldable(foldl')

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

find arr x = do p <- readArray arr x
                if p == -1
                then return x
                else do p' <- find arr p
                        writeArray arr x p'
                        return p'

union arr x y = do x' <- find arr x
                   y' <- find arr y
                   if x' == y' then return () else writeArray arr x' y'

toposort' :: [Int] -> Graph -> IOArray Int Int -> IOArray Int Int -> IO Int
toposort' (u:xs) graph d c = do s <- forM ys (\v -> do  cv' <- readArray c v
                                                        cu  <- readArray c u
                                                        dv' <- readArray d v
                                                        let cv = max cv' $ cu + 1
                                                        let dv = dv' - 1
                                                        writeArray c v cv
                                                        writeArray d v dv
                                                        if dv /= 0 then return 0 else toposort' [v] graph d c)
                                (sum s+1+) <$> toposort' xs graph d c
                                    where ys = graph ! u
toposort' [] _ _ _ = return 0

toposort graph = do let ind = indegree graph
                    d <- thaw ind :: IO (IOArray Int Int)
                    c <- newArray (bounds graph) 0 :: IO (IOArray Int Int)
                    let (_,xs) = foldl' f (0,[]) ind
                    forM_ xs (\x -> writeArray c x 1)
                    tot <- toposort' xs graph d c
                    c' <- freeze c :: IO (Array Int Int)
                    return (if tot /= numElements c' then Nothing else Just c')
                        where f (i,r) x = (i+1,if x == 0 then i:r else r)
                              numElements = (\(i,j) -> j-i+1) . bounds

main = do [n,m] <- readInts
          table <- replicateM n getLine
          arr <- newArray (0,n+m-1) (-1) :: IO (IOArray Int Int)
          let (xs,ys) = partition (\(_,_,c) -> c == '=') . concat . zipWith (\i s -> zipWith (\j c -> (i,j+n,c)) [0..] s) [0..] $ table
          forM_ xs (\(i,j,_) -> union arr i j)
          leaders <- filterM (\i -> (== i) <$> find arr i) [0..(n+m-1)] :: IO [Int]
          let nodeId = array (0,n+m-1) $ zip leaders [0..] :: Array Int Int
          edges <- forM ys (\(i,j,c) -> do  u <- (nodeId !) <$> find arr i
                                            v <- (nodeId !) <$> find arr j
                                            return (if c == '<' then (u,v) else (v,u)))
          let graph = buildG (0,length leaders - 1) edges
          c <- toposort graph
          case c of
              Nothing -> putStr "No"
              Just c' -> do putStrLn "Yes"
                            xc <- getColor [0..(n-1)]
                            yc <- getColor [n..(n+m-1)]
                            putStrLn $ unwords xc
                            putStrLn $ unwords yc
                                where getColor = mapM (\i -> show . (c' !) . (nodeId !) <$> find arr i)

{-# LANGUAGE BangPatterns #-}
import Control.Monad
import qualified Data.ByteString.Char8 as B

import Data.Maybe
import Data.List(partition)
import Data.Array.IO.Safe
import Data.Array.IArray
import Data.Array.MArray.Safe
import Data.Graph
import Data.Foldable(foldl')

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

find arr x = do p <- readArray arr x
                if p == -1
                then return x
                else do p' <- find arr p
                        writeArray arr x p'
                        return p'

union arr x y = do x' <- find arr x
                   y' <- find arr y
                   if x' == y' then return () else writeArray arr x' y'

toposort' :: [Int] -> Graph -> IOArray Int Int -> IOArray Int Int -> IO ()
toposort' (u:xs) graph d c = do forM_ ys (\v -> do  cv' <- readArray c v
                                                    cu  <- readArray c u
                                                    dv' <- readArray d v
                                                    let cv = max cv' $ cu + 1
                                                    let dv = dv' - 1
                                                    writeArray c v cv
                                                    writeArray d v dv
                                                    if dv /= 0 then return () else toposort' [v] graph d c)
                                toposort' xs graph d c
                                    where ys = graph ! u
toposort' [] _ _ _ = return ()

toposort graph = do let ind = indegree graph
                    d <- thaw ind :: IO (IOArray Int Int)
                    c <- newArray (bounds graph) 0 :: IO (IOArray Int Int)
                    let (_,xs) = foldl' f (0,[]) ind
                    forM_ xs (\x -> writeArray c x 1)
                    toposort' xs graph d c
                    c' <- freeze c :: IO (Array Int Int)
                    return (if any (\x -> x == 0) c' then Nothing else Just c')
                        where f (i,r) x = (i+1,if x == 0 then i:r else r)

main = do [n,m] <- readInts
          table <- replicateM n getLine
          arr <- newArray (0,n+m-1) (-1) :: IO (IOArray Int Int)
          let (xs,ys) = partition (\(_,_,c) -> c == '=') . concat . zipWith (\i s -> zipWith (\j c -> (i,j+n,c)) [0..] s) [0..] $ table
          forM_ xs (\(i,j,_) -> union arr i j)
          leaders <- filterM (\i -> (== i) <$> find arr i) [0..(n+m-1)] :: IO [Int]
          let nodeId = array (0,n+m-1) $ zip leaders [0..] :: Array Int Int
          edges <- forM ys (\(i,j,c) -> do  u <- (nodeId !) <$> find arr i
                                            v <- (nodeId !) <$> find arr j
                                            return (if c == '<' then (u,v) else (v,u)))
          let graph = buildG (0,length leaders - 1) edges
          c <- toposort graph
          case c of
              Nothing -> putStr "No"
              Just c' -> do putStrLn "Yes"
                            xc <- getColor [0..(n-1)]
                            yc <- getColor [n..(n+m-1)]
                            putStrLn $ unwords xc
                            putStrLn $ unwords yc
                                where getColor = mapM (\i -> show . (c' !) . (nodeId !) <$> find arr i)


Polycarp is mad about coding, that is why he writes Sveta encoded messages. He calls the median letter in a word the letter which is in the middle of the word. If the word's length is even, the median letter is the left of the two middle letters. In the following examples, the median letter is highlighted: contest, info. If the word consists of single letter, then according to above definition this letter is the median letter. Polycarp encodes each word in the following way: he writes down the median letter of the word, then deletes it and repeats the process until there are no letters left. For example, he encodes the word volga as logva.You are given an encoding s of some word, your task is to decode it.

The first line contains a positive integer n (1 ≤ n ≤ 2000) — the length of the encoded word. The second line contains the string s of length n consisting of lowercase English letters — the encoding.

NoteIn the first example Polycarp encoded the word volga. At first, he wrote down the letter l from the position 3, after that his word looked like voga. After that Polycarp wrote down the letter o from the position 2, his word became vga. Then Polycarp wrote down the letter g which was at the second position, the word became va. Then he wrote down the letter v, then the letter a. Thus, the encoding looked like logva.In the second example Polycarp encoded the word no. He wrote down the letter n, the word became o, and he wrote down the letter o. Thus, in this example, the word and its encoding are the same.In the third example Polycarp encoded the word baba. At first, he wrote down the letter a, which was at the position 2, after that the word looked like bba. Then he wrote down the letter b, which was at the position 2, his word looked like ba. After that he wrote down the letter b, which was at the position 1, the word looked like a, and he wrote down that letter a. Thus, the encoding is abba.

-- Codeforces Round #386 (Div. 2)
-- B. Decoding
-- http://codeforces.com/problemset/problem/746/B

import Control.Monad
import qualified Data.Sequence as Seq
import Data.Foldable (toList, foldl)
import Prelude hiding (foldl)

getInt = read `fmap` getLine :: IO Int

main = do
    n <- getInt
    str <- Seq.fromList `fmap` reverse `fmap` getLine :: IO (Seq.Seq Char)
    putStrLn $ toList (decode str)

decode :: Seq.Seq Char -> Seq.Seq Char
decode s = foldl (\t ch -> insertAt (Seq.length t `div` 2) ch t) Seq.empty s

insertAt k a s = (x Seq.|> a) Seq.>< y where
    (x, y) = Seq.splitAt k s

main = interact $ solve . head . tail . lines
solve = go [] [] where
  go l r (a:b:cs) = go (a:l) (b:r) cs
  go l r [c] = r ++ reverse (c:l)
  go l r [] = l ++ reverse r

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

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

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

  readInteger :: String -> Integer
  readInteger s = read s :: Integer

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

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

  solutions :: Integer -> Integer -> Integer
  solutions n k =
    let midIndex = (2 ^ (n - 1))
    in case compare k midIndex of
      GT -> solutions (n - 1) (k - midIndex)
      LT -> solutions (n - 1) (midIndex - k)
      EQ -> n

  solverEven :: String -> String -> String
  solverEven [] ys = ys
  solverEven (x:xs) ys
    | length ys `mod` 2 == 0 = solverEven xs (x:ys)
    | length ys `mod` 2 == 1 = solverEven xs (ys ++ [x])

  solverOdd :: String -> String -> String
  solverOdd [] ys = ys
  solverOdd (x:xs) ys
    | length ys `mod` 2 == 1 = solverOdd xs (x:ys)
    | length ys `mod` 2 == 0 = solverOdd xs (ys ++ [x])

  solver :: String -> String
  solver xs
    | length xs `mod` 2 == 1 = solverOdd xs []
    | length xs `mod` 2 == 0 = solverEven xs []

  main :: IO()
  main = do
    n <- getLine >>= return . readInteger
    xs <- getLine
    putStrLn $ solver xs

{-# LANGUAGE BangPatterns #-}

main = do
  n <- readLn
  cs <- getLine
  putStrLn $ solve n cs

solve :: Int -> String -> String
solve 1 [c] = [c]
solve 2 [c, d] = [c, d]
solve n cs = go (even n) [] [] cs
  where
    go True ls rs (c:d:cs) = go True (c:ls) (d:rs) cs
    go False ls rs (c:cs) = go True (c:ls) rs cs
    go _ ls rs [] = ls ++ reverse rs

main = interact $ (\[n,s] -> decode (read n) s "") . words

decode :: Int -> String -> String -> String
decode _ "" res = res
decode n (x:xs) res | even n    = decode (n - 1) xs (x : res)
                    | otherwise = decode (n - 1) xs (res ++ [x])

main = interact $ show . solve . head . tail . lines
solve = go [] [] where
  go l r (a:b:cs) = go (a:l) (b:r) cs
  go l r [c] = r ++ reverse (c:l)
  go l r [] = l ++ reverse r


Let's define a string <x> as an opening tag, where x is any small letter of the Latin alphabet. Each opening tag matches a closing tag of the type </x>, where x is the same letter.Tegs can be nested into each other: in this case one opening and closing tag pair is located inside another pair.Let's define the notion of a XML-text:   an empty string is a XML-text  if s is a XML-text, then s'=<a>+s+</a> also is a XML-text, where a is any small Latin letter  if s1, s2 are XML-texts, then s1+s2 also is a XML-text You are given a XML-text (it is guaranteed that the text is valid), your task is to print in the following form:   each tag (opening and closing) is located on a single line  print before the tag 2 * h spaces, where h is the level of the tag's nestedness.

The input data consists on the only non-empty string — the XML-text, its length does not exceed 1000 characters. It is guaranteed that the text is valid. The text contains no spaces.

Print the given XML-text according to the above-given rules.

solve :: String -> [String]
solve s  =  solve' 0 s
  where
    solve' n []  =  []
    solve' n s
      | s !! 1 == '/'  =
        (replicate (n-2) ' ' ++ take 4 s) : (solve' (n-2) (drop 4 s))
      | otherwise  =
        (replicate n ' ' ++ take 3 s) : (solve' (n+2) (drop 3 s))

main :: IO ()
main  =  getLine >>= mapM_ putStrLn . solve

indent lvl tag = (replicate (2 * lvl) ' ') ++ tag ++ "\n"

parse _ [] = []
parse lvl ('<':x:'>':xs)     = (indent lvl ['<', x, '>'])            ++ parse (lvl + 1) xs
parse lvl ('<':'/':x:'>':xs) = (indent (lvl - 1) ['<', '/', x, '>']) ++ parse (lvl - 1) xs
parse lvl (_:xs) = parse lvl xs

main = interact $ parse 0

indent lvl tag = (replicate (2 * lvl) ' ') ++ tag ++ "\n"

parse _ [] = []
parse lvl ('<':x:'>':xs)     = (indent lvl ['<', x, '>'])            ++ parse (lvl + 1) xs
parse lvl ('<':'/':x:'>':xs) = (indent (lvl - 1) ['<', '/', x, '>']) ++ parse (lvl - 1) xs

main = do text <- getLine
          putStr $ parse 0 text

split = (filter (\x->length x > 0)) . words . (map (\x->if (elem x "<>") then ' ' else x))
solve = fst . (foldl g ("", 0))
    where g (res, cnt) it = (res ++ (take (2*(if (head it=='/') then cnt - 1 else cnt)) (repeat ' ')) ++ "<" ++ it ++ ">\n", if (head it == '/') then cnt - 1 else cnt + 1)
main = interact $ solve . split

main = interact (solve 0)

solve d ('>':xs) = ">\n"++solve d xs
solve d ('<':'/':xs) = replicate ((d-1)*2) ' ' ++ "</" ++ solve (d - 1) xs
solve d ('<':xs) = replicate (d*2) ' ' ++ "<" ++ solve (d + 1) xs
solve d (x:xs) = x : solve d xs
solve _ [] = ""

import Text.Printf

spaces :: String
spaces = repeat ' '

xML :: String -> String
xML = loop 0
 where
  loop _  ""                        = ""
  loop n  ('<' : c : '>' : s)       = printf "%s<%s>\n"   (take (n  * 2) spaces) [c] ++ loop n' s
   where n' = n + 1
  loop n ~('<' : '/' : c : '>' : s) = printf "%s</%s>\n"  (take (n' * 2) spaces) [c] ++ loop n' s
   where n' = n - 1

main :: IO ()
main = getLine >>= putStrLn . xML

import Data.List

data Tag = Open | Close deriving (Eq)

splitTag str =
    if length str > 0 then
        let (f,b) = span (/='>') str
            tagType = if length f == 2 then Open else Close
            tag = f++[(head b)]
            rest = tail b
        in
          Just ((tagType, tag), rest)
    else
        Nothing

solve xml = ppnt 0 $ unfoldr splitTag xml
    where
      ppnt _ [] = ""
      ppnt n ((typ,tag):xs) = ("\n"++(replicate (if typ==Open then n else n-2) ' ')++tag)++(ppnt (if typ==Open then n+2 else n-2) xs)

main = getLine >>= putStrLn.tail.solve


You are given two integers $$$n$$$ and $$$k$$$. Your task is to find if $$$n$$$ can be represented as a sum of $$$k$$$ distinct positive odd (not divisible by $$$2$$$) integers or not.You have to answer $$$t$$$ independent test cases.

The first line of the input contains one integer $$$t$$$ ($$$1 \le t \le 10^5$$$) — the number of test cases. The next $$$t$$$ lines describe test cases. The only line of the test case contains two integers $$$n$$$ and $$$k$$$ ($$$1 \le n, k \le 10^7$$$).

For each test case, print the answer — "YES" (without quotes) if $$$n$$$ can be represented as a sum of $$$k$$$ distinct positive odd (not divisible by $$$2$$$) integers and "NO" otherwise.

NoteIn the first test case, you can represent $$$3$$$ as $$$3$$$.In the second test case, the only way to represent $$$4$$$ is $$$1+3$$$.In the third test case, you cannot represent $$$10$$$ as the sum of three distinct positive odd integers.In the fourth test case, you can represent $$$10$$$ as $$$3+7$$$, for example.In the fifth test case, you can represent $$$16$$$ as $$$1+3+5+7$$$.In the sixth test case, you cannot represent $$$16$$$ as the sum of five distinct positive odd integers.

main :: IO ()
main = do
    t_str <- getLine
    let t = read t_str
    printElem [1..t]

printElem :: Show a => [a] -> IO ()
printElem [] = putStrLn ""
printElem (x:xs) = do
    nk_str <- getLine
    let n = read (head (words nk_str))
    let k = read( last (words nk_str))
    putStrLn (solve n k)
    printElem xs

solve :: Integer -> Integer -> String
solve n k
    | ((n `mod` 2 == k `mod` 2) && (n >= (k ^ 2))) = "YES"
    | otherwise = "NO"

main :: IO ()
main = do
    t_str <- getLine
    let t = read t_str :: Integer
    printList [1..t]

printList :: (Show a) => [a] -> IO ()
printList [] = putStr ""
printList (x:xs) = do
    case_str <- getLine
    let n = (read (head (words case_str)) :: Integer)
    let k = (read (last (words case_str)) :: Integer)
    putStrLn (solve n k)
    printList xs

solve :: Integer -> Integer -> String
solve n k
    | ((n >= (k * k)) && ((n `mod` 2) == (k `mod` 2))) = "YES"
    | otherwise = "NO"

import Control.Monad

main = do
    numTests <- read <$> getLine
    replicateM_ numTests $ do
        [n, k] <- map read . words <$> getLine
        if n < k*k || n `mod` 2 /= k `mod` 2 then
            putStrLn "NO"
        else
            putStrLn "YES"

solve :: Integer -> Integer -> Bool
solve n k
  | n < k*k          = False
  | even n && even k = True
  | odd n  && even k = False
  | even n && odd k  = False
  | otherwise        = True

solve' :: Integer -> Integer -> String
solve' n k = if solve n k then "YES" else "NO"

parse :: String -> String
parse input = solve' n k
  where [n, k] = map (\x -> read x :: Integer) $ words input

main :: IO ()
main = interact (unlines . map parse . tail . lines)

import Data.Bits
import Control.Monad

main :: IO ()
main = do
    getLine
    answers <- map (solve . map read . words) <$> lines <$> getContents :: IO [String]
    forM_ answers putStrLn

solve :: [Integer] -> String
solve [x,y]
    | odd x `xor` odd y = "NO"
    | otherwise         = case x < y^2 of
                            True    -> "NO"
                            _       -> "YES"

import Control.Monad

-- solve :: Integer -> Integer -> String
solve n k = if n >= k^2 && n `mod` 2 == k `mod` 2 then "YES" else "NO"

main = do
        t <- fmap read getLine
        forM [1..t] (\_ -> do
          [n, k] <- fmap (map read.words) getLine
          putStrLn (solve n k))

import Control.Arrow
import Data.Array as Array

main = interact $
  lines >>> drop 1 >>> map (words >>> map read >>> solve) >>> unlines >>> (++"\n")

solve :: [Integer] -> String
solve [n, k]
  | n < k * k = "NO"
  | odd (n - k * k) = "NO"
  | otherwise = "YES"

module Main where

import Control.Monad
import Data.List

getStrList :: IO [String]
getStrList = words <$> getLine

getIntList :: IO [Int]
getIntList = map read <$> getStrList

printStrList :: [String] -> IO ()
printStrList = putStrLn . intercalate " "

printList :: (Show a) => [a] -> IO ()
printList = printStrList . map show

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

(-->) :: a -> (a -> b) -> b
(-->) = flip ($)

main :: IO ()
main = do
    t <- readLn
    replicateM_ t $ do
        [n, k] <- (map read <$> getStrList) :: IO [Integer]
        putStrLn . yesOrNo . and $ [n `mod` 2 == k `mod` 2, n >= k * k]

solve ([a, b]) = if a `mod` 2 /= b `mod` 2 then "NO" else if a < b*b then "NO" else "YES"

main = do
    x <- getLine
    interact (unlines . map ( solve . (map read) . words ) . lines )

module Main where

isInt x = x == fromInteger (round x)

other :: IO ()
other = do
    ln <- getLine
    let ints = map read (words ln) :: [Integer]
    putStrLn $ if even (ints !! 0) == even (ints !! 1)
               then if (ints !! 1) ^ 2 > (ints !! 0)
                    then "NO"
                    else "YES"
               else "NO"

name 1 = other
name t = do
    other
    name $ t - 1

main = do
    t <- getLine
    name $ read t

module Main where

isInt x = x == fromInteger (round x)

other :: IO ()
other = do
    ln <- getLine
    let ints = map read (words ln) :: [Integer]
    let n = ints !! 0
    let k = fromIntegral (ints !! 1)
    putStrLn $ if even n == even k
               then if k * k > n
                    then "NO"
                    else "YES"
               else "NO"

name 1 = other
name t = do
    other
    name $ t - 1

main = do
    t <- getLine
    name $ read t

main :: IO ()
main = do
    t_str <- getLine
    let t = read t_str :: Int
    printList [1..t]

printList :: (Show a) => [a] -> IO ()
printList [] = putStr ""
printList (x:xs) = do
    case_str <- getLine
    let n = (read (head (words case_str)) :: Int)
    let k = (read (last (words case_str)) :: Int)
    putStrLn (solve n k)
    printList xs

solve :: Int -> Int -> String
solve n k
    | (((n `mod` 2) == (k `mod` 2)) && (n >= (k * k))) = "YES"
    | otherwise = "NO"

main :: IO ()
main = do
    t_str <- getLine
    let t = read t_str
    printElem [1..t]

printElem :: Show a => [a] -> IO ()
printElem [] = putStrLn ""
printElem (x:xs) = do
    nk_str <- getLine
    let n = read (head (words nk_str))
    let k = read( last (words nk_str))
    putStrLn (solve n k)
    printElem xs

solve :: Integer -> Integer -> String
solve n k
    | (n `mod` 2 == k `mod` 2) = "YES"
    | otherwise = "NO"

solve :: Integer -> Integer -> Bool
solve n k
  | n < k            = False
  | even n && even k = True
  | odd n  && even k = False
  | even n && odd k  = False
  | otherwise        = True

solve' :: Integer -> Integer -> String
solve' n k = if solve n k then "YES" else "NO"

parse :: String -> String
parse input = solve' n k
  where [n, k] = map (\x -> read x :: Integer) $ words input

main :: IO ()
main = interact (unlines . map parse . tail . lines)

solve :: Integer -> Integer -> Bool
solve n k
  | even n && even k = True
  | odd n  && even k = False
  | even n && odd k  = False
  | otherwise        = True

solve' :: Integer -> Integer -> String
solve' n k = if solve n k then "YES" else "NO"

parse :: String -> String
parse input = solve' n k
  where [n, k] = map (\x -> read x :: Integer) $ words input

main :: IO ()
main = interact (unlines . map parse . tail . lines)

import Data.Bits
import Control.Monad

main :: IO ()
main = do
    getLine
    answers <- map (solve . map read . words) <$> lines <$> getContents :: IO [String]
    forM_ answers putStrLn

solve :: [Int] -> String
solve [x,y]
    | odd x `xor` odd y = "NO"
    | otherwise         = case x < y^2 of
                            True    -> "NO"
                            _       -> "YES"

import Control.Monad

solve :: Int -> Int -> String
solve n k = if n >= k^2 && n `mod` 2 == k `mod` 2 then "YES" else "NO"

main = do
        t <- fmap read getLine
        forM [1..t] (\_ -> do
          [n, k] <- fmap (map read.words) getLine
          putStrLn (solve n k))

import Control.Arrow
import Data.Array as Array

main = interact $
  lines >>> drop 1 >>> map (words >>> map read >>> solve) >>> unlines >>> (++"\n")

solve :: [Int] -> String
solve [n, k]
  | n < k * k = "NO"
  | odd (n - k) = "NO"
  | otherwise = "YES"

import Control.Arrow
import Data.Array as Array

main = interact $
  lines >>> drop 1 >>> map (words >>> map read >>> solve) >>> unlines >>> (++"\n")

solve :: [Int] -> String
solve [n, k]
  | n < k * k = "NO"
  | odd (n - k * k) = "NO"
  | otherwise = "YES"

import Control.Arrow
import Data.Array as Array

main = interact $
  lines >>> drop 1 >>> map (words >>> map read >>> solve) >>> unlines >>> (++"\n")

solve :: [Int] -> String
solve [n, k]
  | n < k = "NO"
  | odd (n - k) = "NO"
  | otherwise = "YES"

module Main where

isInt x = x == fromInteger (round x)

other :: IO ()
other = do
    ln <- getLine
    let ints = map read (words ln) :: [Int]
    let n = ints !! 0
    let k = ints !! 1
    putStrLn $ if even n == even k
               then if (sum $ take k [1,3..]) > n
                    then "NO"
                    else "YES"
               else "NO"

name 1 = other
name t = do
    other
    name $ t - 1

main = do
    t <- getLine
    name $ read t

module Main where

isInt x = x == fromInteger (round x)

name :: Integer -> IO ()
name 1 = do
    ln <- getLine
    let ints = map read (words ln) :: [Integer]
    putStrLn $ if isInt (fromIntegral (ints !! 0) / fromIntegral (ints !! 1))
               then "YES"
               else "NO"
name t = do
    ln <- getLine
    let ints = map read (words ln) :: [Integer]
    putStrLn $ if isInt (fromIntegral (ints !! 0) / fromIntegral (ints !! 1))
               then "YES"
               else "NO"
    name $ t - 1

main = do
    t <- getLine
    name $ read t


Every year a race takes place on the motorway between cities A and B. This year Vanya decided to take part in the race and drive his own car that has been around and bears its own noble name — The Huff-puffer.So, Vasya leaves city A on the Huff-puffer, besides, at the very beginning he fills the petrol tank with α liters of petrol (α ≥ 10 is Vanya's favorite number, it is not necessarily integer). Petrol stations are located on the motorway at an interval of 100 kilometers, i.e. the first station is located 100 kilometers away from the city A, the second one is 200 kilometers away from the city A, the third one is 300 kilometers away from the city A and so on. The Huff-puffer spends 10 liters of petrol every 100 kilometers. Vanya checks the petrol tank every time he passes by a petrol station. If the petrol left in the tank is not enough to get to the next station, Vanya fills the tank with α liters of petrol. Otherwise, he doesn't stop at the station and drives on. For example, if α = 43.21, then the car will be fuelled up for the first time at the station number 4, when there'll be 3.21 petrol liters left. After the fuelling up the car will have 46.42 liters. Then Vanya stops at the station number 8 and ends up with 6.42 + 43.21 = 49.63 liters. The next stop is at the station number 12, 9.63 + 43.21 = 52.84. The next stop is at the station number 17 and so on. You won't believe this but the Huff-puffer has been leading in the race! Perhaps it is due to unexpected snow. Perhaps it is due to video cameras that have been installed along the motorway which register speed limit breaking. Perhaps it is due to the fact that Vanya threatened to junk the Huff-puffer unless the car wins. Whatever the reason is, the Huff-puffer is leading, and jealous people together with other contestants wrack their brains trying to think of a way to stop that outrage.One way to do this is to mine the next petrol station where Vanya will stop. Your task is to calculate at which station this will happen and warn Vanya. You don't know the α number, however, you are given the succession of the numbers of the stations where Vanya has stopped. Find the number of the station where the next stop will be.

The first line contains an integer n (1 ≤ n ≤ 1000) which represents the number of petrol stations where Vanya has stopped. The next line has n space-separated integers which represent the numbers of the stations. The numbers are positive and do not exceed 106, they are given in the increasing order. No two numbers in the succession match. It is guaranteed that there exists at least one number α ≥ 10, to which such a succession of stops corresponds.

Print in the first line "unique" (without quotes) if the answer can be determined uniquely. In the second line print the number of the station where the next stop will take place. If the answer is not unique, print in the first line "not unique".

NoteIn the second example the answer is not unique. For example, if α = 10, we'll have such a sequence as 1, 2, 3, and if α = 14, the sequence will be 1, 2, 4.

main = interact solve
solve input = output where
  [[n],stop] = map (map (read:: String -> Double)) $ map words $ lines input
  output = if u==l || (l==l1 && u==l+1) then "unique\n" ++ show (u-1)
                                        else "not unique"
   where (t,u0,l0) = gas $ reverse stop
         u = ceiling (u0 * t / 10)
         l = ceiling (l0 * t / 10)
         l1 = floor (l0 * t / 10)
gas [x] = (2,10.0*(x+1),10.0*x)
gas (x:xs) = (t+1,min u (10.0*(x+1)/t),max l (10.0*x/t))
   where (t,u,l) = gas xs

main = interact solve
solve input = output where
  [[n],stop] = map (map (read:: String -> Double)) $ map words $ lines input
  output = if u>l then "not unique" else "unique\n" ++ show (u-1)
   where (t,u0,l0) = gas $ reverse stop
         u = ceiling (u0 * t / 10)
         l = ceiling (l0 * t / 10)
gas [x] = (2,10.0*(x+1),10.0*x)
gas (x:xs) = (t+1,min u (10.0*(x+1)/t),max l (10.0*x/t))
   where (t,u,l) = gas xs

main = interact solve
solve input = output where
  [[n],stop] = map (map (read:: String -> Float)) $ map words $ lines input
  output = if u>l then "not unique" else "unique\n" ++ show (u-1)
   where (t,u0,l0) = gas $ reverse stop
         u = ceiling (u0 * t / 10)
         l = ceiling (l0 * t / 10)
gas [x] = (2,10.0*(x+1),10.0*x)
gas (x:xs) = (t+1,min u (10.0*(x+1)/t),max l (10.0*x/t))
   where (t,u,l) = gas xs


You are given a colored permutation $$$p_1, p_2, \dots, p_n$$$. The $$$i$$$-th element of the permutation has color $$$c_i$$$.Let's define an infinite path as infinite sequence $$$i, p[i], p[p[i]], p[p[p[i]]] \dots$$$ where all elements have same color ($$$c[i] = c[p[i]] = c[p[p[i]]] = \dots$$$).We can also define a multiplication of permutations $$$a$$$ and $$$b$$$ as permutation $$$c = a \times b$$$ where $$$c[i] = b[a[i]]$$$. Moreover, we can define a power $$$k$$$ of permutation $$$p$$$ as $$$p^k=\underbrace{p \times p \times \dots \times p}_{k \text{ times}}$$$.Find the minimum $$$k > 0$$$ such that $$$p^k$$$ has at least one infinite path (i.e. there is a position $$$i$$$ in $$$p^k$$$ such that the sequence starting from $$$i$$$ is an infinite path).It can be proved that the answer always exists.

The first line contains single integer $$$T$$$ ($$$1 \le T \le 10^4$$$) — the number of test cases. Next $$$3T$$$ lines contain test cases — one per three lines. The first line contains single integer $$$n$$$ ($$$1 \le n \le 2 \cdot 10^5$$$) — the size of the permutation. The second line contains $$$n$$$ integers $$$p_1, p_2, \dots, p_n$$$ ($$$1 \le p_i \le n$$$, $$$p_i \neq p_j$$$ for $$$i \neq j$$$) — the permutation $$$p$$$. The third line contains $$$n$$$ integers $$$c_1, c_2, \dots, c_n$$$ ($$$1 \le c_i \le n$$$) — the colors of elements of the permutation. It is guaranteed that the total sum of $$$n$$$ doesn't exceed $$$2 \cdot 10^5$$$.

Print $$$T$$$ integers — one per test case. For each test case print minimum $$$k > 0$$$ such that $$$p^k$$$ has at least one infinite path.

NoteIn the first test case, $$$p^1 = p = [1, 3, 4, 2]$$$ and the sequence starting from $$$1$$$: $$$1, p[1] = 1, \dots$$$ is an infinite path.In the second test case, $$$p^5 = [1, 2, 3, 4, 5]$$$ and it obviously contains several infinite paths.In the third test case, $$$p^2 = [3, 6, 1, 8, 7, 2, 5, 4]$$$ and the sequence starting from $$$4$$$: $$$4, p^2[4]=8, p^2[8]=4, \dots$$$ is an infinite path since $$$c_4 = c_8 = 4$$$.

{-# LANGUAGE Safe #-}

import Control.Arrow ((>>>))
import qualified Data.ByteString.Lazy.Char8 as C
import safe Data.Graph (flattenSCC, stronglyConnComp)
import safe Data.Maybe (catMaybes, fromJust)

main :: IO ()
main =
  C.interact $
    C.lines >>> drop 1
      >>> map (C.words >>> map readInt)
      >>> process
      >>> map (show >>> C.pack)
      >>> C.unlines
  where
    readInt = C.readInt >>> fromJust >>> fst

process :: [[Int]] -> [Int]
process [] = []
process ([n] : ps : cs : xs) = solve n ps cs : process xs

solve :: Int -> [Int] -> [Int] -> Int
solve _ ps cs = minimum $ best . flattenSCC <$> stronglyConnComp (zip3 cs [1 ..] ((: []) <$> ps))

best :: [Int] -> Int
best xs = head $ filter check $ filter ((== 0) . (n `mod`)) [1 .. n]
  where
    n = length xs

    check :: Int -> Bool
    check len = not . null . catMaybes $ groupZip len [] xs

    groupZip :: Int -> [Maybe Int] -> [Int] -> [Maybe Int]
    groupZip _ cur [] = cur
    groupZip len [] xs = groupZip len (Just <$> take len xs) (drop len xs)
    groupZip len cur xs = groupZip len (zipWith comb cur (take len xs)) (drop len xs)
      where
        comb Nothing _ = Nothing
        comb (Just x) y = if x == y then Just x else Nothing

import Data.Bool
import Data.Maybe
import Data.Array
import Data.List
import Control.Monad
--newtype Cycle = Cycle {colors :: Array Int Color}
type Cycle = Array Index Color
type Color = Int
type Index = Int
type Givens = (Int, Array Index Index, Array Index Color)
type Changing = (Index,Array Index Bool, [Cycle])

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

routine :: IO ()
routine = do
  n <- readLn
  perm <- (map (read :: String -> Int).words) <$> getLine
  cols <- (map (read :: String -> Int).words) <$> getLine
  let givens = (n,listArray (1,n) perm, listArray (1,n) cols)
  print $ smallestPower $ finish givens (start n)

start :: Int -> Changing
start n = (1,listArray (1,n) (replicate n False) ,[])

f :: Givens -> Changing -> Either [Cycle] Changing
f (n,perm,colors) (i,seen,cys)
  |i>n = Left cys
  |seen!i = Right (i+1,seen,cys)
  |otherwise =Right (i+1,newSeen,newCys)
  where
    newPerm = makeOneCycle perm i
    newSeen = updateSeen newPerm seen
    newCys = makeCycle newPerm colors : cys

finish :: Givens -> Changing -> [Cycle]
finish g ch = case f g ch of
  Left cys -> cys
  Right newCh -> finish g newCh

updateSeen :: Array Index Index -> Array Index Bool -> Array Index Bool
updateSeen arr seen = seen // map (\x -> (x,True)) (elems arr)

makeCycle ::  Array Index Index -> Array Int Color -> Cycle
makeCycle arr cols = (\x -> cols!x) <$> arr

makeOneCycle :: Array Index Index -> Int -> Array Index Index
makeOneCycle perm i = listArray (1,length list) list
  where
    stream = iterate (\ind -> perm!ind) (perm!i)
    list =i : takeWhile (/=i) stream

smallestPower :: [Cycle] -> Int
smallestPower cs = minimum (map processCycle cs)

divisors :: Int -> [Int]
divisors n = lows ++ bool id tail (n == root * root) (reverse (quot n <$> lows))
  where
    root = (floor . (sqrt:: Double -> Double) . fromIntegral) n
    lows = filter ((0==) . rem n) [1..root]

divisorTest :: Cycle -> Int -> Bool
divisorTest cy di = or alltests
  where
    (_,leng) = bounds cy
    testcyc n = all (==cy!n) [cy!(n+(x-1)*di) | x <- [1..(leng `div` di)]]
    alltests = map testcyc [1..di]

processCycle :: Cycle -> Int
processCycle cy = firstDiv
  where
    (_,leng) = bounds cy
    divs = divisors leng
    firstDiv =  fromJust $ find (divisorTest cy) divs


Recently, Vlad has been carried away by spanning trees, so his friends, without hesitation, gave him a connected weighted undirected graph of $$$n$$$ vertices and $$$m$$$ edges for his birthday.Vlad defined the ority of a spanning tree as the bitwise OR of all its weights, and now he is interested in what is the minimum possible ority that can be achieved by choosing a certain spanning tree. A spanning tree is a connected subgraph of a given graph that does not contain cycles.In other words, you want to keep $$$n-1$$$ edges so that the graph remains connected and the bitwise OR weights of the edges are as small as possible. You have to find the minimum bitwise OR itself.

The first line of the input contains an integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of test cases in the input. An empty line is written in front of each test case. This is followed by two numbers $$$n$$$ and $$$m$$$ ($$$3 \le n \le 2 \cdot 10^5, n - 1 \le m \le 2 \cdot 10^5$$$) — the number of vertices and edges of the graph, respectively. The next $$$m$$$ lines contain the description of the edges. Line $$$i$$$ contains three numbers $$$v_i$$$, $$$u_i$$$ and $$$w_i$$$ ($$$1 \le v_i, u_i \le n$$$, $$$1 \le w_i \le 10^9$$$, $$$v_i \neq u_i$$$) — the vertices that the edge connects and its weight. It is guaranteed that the sum $$$m$$$ and the sum $$$n$$$ over all test cases does not exceed $$$2 \cdot 10^5$$$ and each test case contains a connected graph.

Print $$$t$$$ lines, each of which contains the answer to the corresponding set of input data — the minimum possible spanning tree ority.

Note  Graph from the first test case.   Ority of this tree equals to 2 or 2 = 2 and it's minimal.   Without excluding edge with weight $$$1$$$ ority is 1 or 2 = 3.

{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
import qualified Data.ByteString.Lazy.Char8 as P
import Data.ByteString.Builder
import qualified Data.ByteString.Builder.Prim as Prim
import System.IO
import Control.Monad.Trans.State
import Data.Maybe

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

maxBits :: Int
maxBits = 30

-- Perhaps packing (to traverse fewer lists) will help?
isConnected :: Array Int (UArray Int Int) -> Int -> Bool
isConnected arr mask = runST $ do
  let  (li, ri) = bounds arr
  vis :: STUArray s Int Bool
      <- newArray (li, ri) False :: ST s (STUArray s Int Bool)
  let
    dfs :: Int -> [Int] -> ST s Int
    dfs !ct [] = pure ct
    dfs !ct (v : vs) = do
      isVis <- readArray vis v
      writeArray vis v True
      if  isVis
        then  dfs ct vs
        else  let
        nbrs = do
          uw <- elems $ arr !  v
          let  u = uw .&. (bit maxBits - 1)
               w = uw `shiftR` maxBits
          guard $ w .&. mask == w
          pure u
        -- weird concatenation style to prevent thunks from existing
        vs' = foldl' (flip (:)) vs nbrs
        in  dfs (ct + 1) vs'
  ccsz <- dfs 0 [li]
  pure $ ccsz == ri + 1 - li

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    es <- replicateM m $ do
      wasThisContributingToBadMemoryUse <- getInts 3
      -- I should profile it, but I don't feel like it right now
      case  wasThisContributingToBadMemoryUse  of
        [!vi, !ui, !wi] -> pure (vi, ui, wi)
        _ -> error "bad input format"
    let
      adj :: Array Int [Int]
      adj = accumArray (flip (:)) [] (1, n) $ do
        (vi, ui, wi) <- es
        let  !vw = pack (vi, wi)
             !uw = pack (ui, wi)
        [(ui, vw), (vi, uw)]
      pack (u, w) = u + shiftL w maxBits
      adj2 = (\li -> listArray (1, length li) li) <$> adj
      isOK :: Int -> Bool
      isOK = isConnected adj2
      solve s j = if  j < 0
        then  s
        else  let
        s' = s - bit j
        in  if  isOK s'
        then  solve s' (j - 1)
        else  solve s  (j - 1)
    pure $ putInts [solve (bit maxBits - 1) (maxBits - 1)]

type SP = State [P.ByteString]

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

getInts :: Int -> SP [Int]
getInts k = map (fst . fromJust . P.readInt) <$> getNext k

putInts :: [Int] -> Builder
putInts vs = let
  sepPrim = (,) ' ' Prim.>$<
    Prim.liftFixedToBounded Prim.char7 Prim.>*< Prim.intDec
  in  case  vs  of
  [] -> char7 '\n'
  x : xs -> intDec x <> Prim.primMapListBounded sepPrim xs <> char7 '\n'

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  inp <- P.getContents
  let  outp = evalState mainFun $ P.words inp
  P.putStr $ toLazyByteString outp

{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
import qualified Data.ByteString.Lazy.Char8 as P
import Data.ByteString.Builder
import qualified Data.ByteString.Builder.Prim as Prim
import System.IO
import Control.Monad.Trans.State
import Data.Maybe

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

maxBits :: Int
maxBits = 30

-- Perhaps packing (to traverse fewer lists) will help?
isConnected :: Array Int (UArray Int Int) -> Int -> Bool
isConnected arr mask = runST $ do
  let  (li, ri) = bounds arr
  vis :: STUArray s Int Bool
      <- newArray (li, ri) False :: ST s (STUArray s Int Bool)
  let
    dfs :: Int -> [Int] -> ST s Int
    dfs !ct [] = pure ct
    dfs !ct (v : vs) = do
      isVis <- readArray vis v
      writeArray vis v True
      if  isVis
        then  dfs ct vs
        else  let
        nbrs = do
          uw <- elems $ arr !  v
          let  u = uw .&. (bit maxBits - 1)
               w = uw `shiftR` maxBits
          guard $ w .&. mask == w
          pure u
        -- weird concatenation style to prevent thunks from existing
        vs' = foldl' (flip (:)) vs nbrs
        in  dfs (ct + 1) vs'
  ccsz <- dfs 0 [li]
  pure $ ccsz == ri + 1 - li

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    es <- replicateM m $ do
      wasThisContributingToBadMemoryUse <- getInts 3
      -- I should profile it, but I don't feel like it right now
      case  wasThisContributingToBadMemoryUse  of
        [!vi, !ui, !wi] -> pure (vi, ui, wi)
        _ -> error "bad input format"
    let
      adj :: Array Int [(Int, Int)]
      adj = accumArray (flip (:)) [] (1, n) $ do
        (vi, ui, wi) <- es
        [(ui, (vi, wi)), (vi, (ui, wi))]
      pack (u, w) = u + shiftL w maxBits
      adj2 = (\li -> listArray (1, length li) $ map pack li) <$> adj
      isOK :: Int -> Bool
      isOK = isConnected adj2
      solve s j = if  j < 0
        then  s
        else  let
        s' = s - bit j
        in  if  isOK s'
        then  solve s' (j - 1)
        else  solve s  (j - 1)
    pure $ putInts [solve (bit maxBits - 1) (maxBits - 1)]

type SP = State [P.ByteString]

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

getInts :: Int -> SP [Int]
getInts k = map (fst . fromJust . P.readInt) <$> getNext k

putInts :: [Int] -> Builder
putInts vs = let
  sepPrim = (,) ' ' Prim.>$<
    Prim.liftFixedToBounded Prim.char7 Prim.>*< Prim.intDec
  in  case  vs  of
  [] -> char7 '\n'
  x : xs -> intDec x <> Prim.primMapListBounded sepPrim xs <> char7 '\n'

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  inp <- P.getContents
  let  outp = evalState mainFun $ P.words inp
  P.putStr $ toLazyByteString outp

{-# OPTIONS_GHC -O2 #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Control.DeepSeq
import Control.Monad
import Control.Monad.ST
import Data.Array
import Data.Array.ST
import Data.Bits
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as C

type Vertex = Int
type Weight = Int
data Edge = Edge { w_ :: !Weight, v_ :: !Vertex }

instance NFData Edge where
    rnf (Edge w v) = w `seq` v `seq` ()

data EdgeList = Nil | Cons {-# UNPACK #-} !Edge EdgeList -- For performance reasons only :(

solve :: IO ()
solve = do
    void C.getLine -- why?
    ~[n, m] <- readInts
    g <- fmap (accumArray (flip Cons) Nil (1, n) . concat) $ replicateM m $ do
        ~[u, v, w] <- readInts
        let es = [(u, Edge w v), (v, Edge w u)]
        es `deepseq` pure es
    let f msk i = if connected g ((==0) . (msk' .&.)) then msk' else msk where
            msk' = msk `setBit` i
    print $ ((1 `shiftL` 30) - 1) `xor` foldl' f 0 [29,28..0]

connected :: Array Vertex EdgeList -> (Weight -> Bool) -> Bool
connected g p = runST $ do
    let bnds = bounds g
    vis :: STUArray s Int Bool <- newArray bnds False
    let go u = do
            done <- readArray vis u
            unless done $ do
                writeArray vis u True
                filterSequenceEdgeList p go (g!u) :: ST s ()
    go (fst bnds)
    and <$> getElems vis

filterSequenceEdgeList :: Monad m => (Weight -> Bool) -> (Vertex -> m ()) -> EdgeList -> m ()
filterSequenceEdgeList p f = go where
    go Nil = pure ()
    go (Cons (Edge w v) es)
        | p w       = f v >> go es
        | otherwise = go es

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

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