Valera conducts experiments with algorithms that search for shortest paths. He has recently studied the Floyd's algorithm, so it's time to work with it.Valera's already written the code that counts the shortest distance between any pair of vertexes in a non-directed connected graph from n vertexes and m edges, containing no loops and multiple edges. Besides, Valera's decided to mark part of the vertexes. He's marked exactly k vertexes a1, a2, ..., ak.Valera's code is given below.ans[i][j] // the shortest distance for a pair of vertexes i, ja[i]  // vertexes, marked by Valerafor(i = 1; i <= n; i++) {    for(j = 1; j <= n; j++) {        if (i == j)            ans[i][j] = 0;        else            ans[i][j] = INF;  //INF is a very large number     }}    for(i = 1; i <= m; i++) {    read a pair of vertexes u, v that have a non-directed edge between them;    ans[u][v] = 1;    ans[v][u] = 1;}for (i = 1; i <= k; i++) {    v = a[i];    for(j = 1; j <= n; j++)        for(r = 1; r <= n; r++)            ans[j][r] = min(ans[j][r], ans[j][v] + ans[v][r]);}Valera has seen that his code is wrong. Help the boy. Given the set of marked vertexes a1, a2, ..., ak, find such non-directed connected graph, consisting of n vertexes and m edges, for which Valera's code counts the wrong shortest distance for at least one pair of vertexes (i, j). Valera is really keen to get a graph without any loops and multiple edges. If no such graph exists, print -1.

The first line of the input contains three integers n, m, k (3 ≤ n ≤ 300, 2 ≤ k ≤ n , ) — the number of vertexes, the number of edges and the number of marked vertexes.  The second line of the input contains k space-separated integers a1, a2, ... ak (1 ≤ ai ≤ n) — the numbers of the marked vertexes. It is guaranteed that all numbers ai are distinct.

If the graph doesn't exist, print -1 on a single line. Otherwise, print m lines, each containing two integers u, v — the description of the edges of the graph Valera's been looking for.

{-# LANGUAGE MultiParamTypeClasses,FlexibleContexts,FlexibleInstances,TypeSynonymInstances,BangPatterns,RankNTypes #-}

import Control.Monad
import Control.Monad.ST
import Control.Applicative
import Control.Arrow
import Debug.Trace

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

readInt = B.readInt >>> fmap fst >>> fromMaybe 0
readsInt = map readInt . B.words <$> B.getLine
readLine :: Read a => IO a
readLine = read <$> getLine
readsLine :: Read a => IO [a]
readsLine = map read . words <$> getLine

cmpFst (a,_) (b,_) = compare a b
cmpSnd (_,a) (_,b) = compare a b
cmpLen a b = length a `compare` length b

swap (a,b) = (b,a)
rect a b = rect2 0 0 a b
rect2 i j a b = ((i,j),(a,b))

itof :: Int -> Double
itof = fromIntegral
casti = fromIntegral

maximize f l = snd $ maximumBy cmpFst [(f x,x) | x <- l]
minimize f l = snd $ minimumBy cmpFst [(f x,x) | x <- l]

infixr 2 <||>
infixr 3 <&&>
p1 <||> p2 = (p1 &&& p2) >>> uncurry (||)
p1 <&&> p2 = (p1 &&& p2) >>> uncurry (&&)

main = do
    [n,m,k] <- readsLine
    as      <- readsLine
    case solve n m k as of
        Nothing -> print (-1)
        Just es -> forM_ es $ \(s,t) ->
            putStrLn $ show s ++ " " ++ show t

        {-
v -> u -> w
not (v -> w)
not (v -> u' -> w) ( u <- as )

-}
edge (u,v) | u <= v = (u,v)
           | otherwise = (v,u)
solve n m k as | n == k = Nothing
solve n m k as = go (S.fromList es0) cands
    where
    u : l     = [1..n] \\ as
    v : w : as' = as
    e1 = edge (u,v)
    e2 = edge (u,w)
    e3 = edge (v,w)
    es0 = map edge $ [(v,u),(u,w)] ++ zip (w:as') as' ++ zip (u:l) l
    cands = [(i,j) | i <- [1..n], j <- [i+1..n] , i /= v , j /= v] ++ [ edge (u',v) | u' <- l]
    go !es _ | S.size es == m = Just (S.toList es)
    go !es [] = Nothing
    go !es (e:cands) = go (e `S.insert` es) cands

{-# LANGUAGE BangPatterns #-}
import Control.Monad
import Control.Applicative

import Data.List
import qualified Data.Set as S

readsLine :: Read a => IO [a]
readsLine = map read . words <$> getLine

main = do
    [n,m,k] <- map read . words <$> getLine
    as      <- map read . words <$> getLine
    case solve n m k as of
        Nothing -> print (-1)
        Just es -> forM_ es $ \(s,t) -> putStrLn $ unwords $ map show [s,t]

edge (u,v) = if u <= v then (u,v) else (v,u)

solve n m k as | n == k = Nothing
solve n m k as = go (S.fromList es0) cands
    where
    u : l       = [1..n] \\ as
    v : w : as' = as
    es0 = map edge $ [(v,u),(u,w)] ++ zip (w:as') as' ++ zip (u:l) l
    cands = [(i,j) | i <- [1..n], j <- [i+1..n] , i /= v , j /= v] ++ [ edge (u',v) | u' <- l]
    go !es _ | S.size es == m = Just (S.toList es)
    go !es [] = Nothing
    go !es (e:cands) = go (e `S.insert` es) cands

{-# LANGUAGE BangPatterns #-}
import Control.Monad
import Control.Applicative

import Data.List
import qualified Data.Set as S

readsLine :: Read a => IO [a]
readsLine = map read . words <$> getLine

main = do
    [n,m,k] <- map read . words <$> getLine
    as      <- map read . words <$> getLine
    case solve n m k as of
        Nothing -> print (-1)
        Just es -> putStr $ unlines $ map (\(s,t) -> unwords $ map show [s,t]) es

edge (u,v) = if u <= v then (u,v) else (v,u)

solve n m k as | n == k = Nothing
solve n m k as = go (S.fromList es0) cands
    where
    u : l       = [1..n] \\ as
    v : w : as' = as
    es0 = map edge $ [(v,u),(u,w)] ++ zip (w:as') as' ++ zip (u:l) l
    cands = [(i,j) | i <- [1..n], j <- [i+1..n] , i /= v , j /= v] ++ [ edge (u',v) | u' <- l]
    go !es _ | S.size es == m = Just (S.toList es)
    go !es [] = Nothing
    go !es (e:cands) = go (e `S.insert` es) cands

{-# LANGUAGE BangPatterns #-}
import Control.Monad
import Control.Applicative

import Data.List
import qualified Data.Set as S

readsLine :: Read a => IO [a]
readsLine = map read . words <$> getLine

main = do
    [n,m,k] <- map read . words <$> getLine
    as      <- map read . words <$> getLine
    case solve n m k as of
        Nothing -> print (-1)
        Just es -> putStr $ unlines $ map (\(s,t) ->
            unwords $ map show [s,t]) es

edge (u,v) = if u <= v then (u,v) else (v,u)

solve :: Int -> Int -> Int -> [Int] -> Maybe [(Int,Int)]
solve n m k as | n == k = Nothing
solve n m k as = go (S.fromList es0) cands
    where
    u : l       = [1..n] \\ as
    v : w : as' = as
    es0 = map edge $ [(v,u),(u,w)] ++ zip (w:as') as' ++ zip (u:l) l
    cands = [(i,j) | i <- [1..n], j <- [i+1..n] , i /= v , j /= v] ++
            [ edge (u',v) | u' <- l]
    go !es _ | S.size es == m = Just (S.toList es)
    go !es []                 = Nothing
    go !es (e:cands)          = go (e `S.insert` es) cands

{-# LANGUAGE MultiParamTypeClasses,FlexibleContexts,FlexibleInstances,TypeSynonymInstances,BangPatterns,RankNTypes #-}

import Control.Monad
import Control.Monad.ST
import Control.Applicative
import Control.Arrow
import Debug.Trace

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

readInt = B.readInt >>> fmap fst >>> fromMaybe 0
readsInt = map readInt . B.words <$> B.getLine
readLine :: Read a => IO a
readLine = read <$> getLine
readsLine :: Read a => IO [a]
readsLine = map read . words <$> getLine

cmpFst (a,_) (b,_) = compare a b
cmpSnd (_,a) (_,b) = compare a b
cmpLen a b = length a `compare` length b

swap (a,b) = (b,a)
rect a b = rect2 0 0 a b
rect2 i j a b = ((i,j),(a,b))

itof :: Int -> Double
itof = fromIntegral
casti = fromIntegral

maximize f l = snd $ maximumBy cmpFst [(f x,x) | x <- l]
minimize f l = snd $ minimumBy cmpFst [(f x,x) | x <- l]

infixr 2 <||>
infixr 3 <&&>
p1 <||> p2 = (p1 &&& p2) >>> uncurry (||)
p1 <&&> p2 = (p1 &&& p2) >>> uncurry (&&)

main = do
    [n,m,k] <- readsLine
    as      <- readsLine
    case solve n m k as of
        Nothing -> print (-1)
        Just es -> forM_ es $ \(s,t) ->
            putStrLn $ show s ++ " " ++ show t

        {-
v -> u -> w
not (v -> w)
not (v -> u' -> w) ( u <- as )
-}
edge u v | u <= v = (u,v)
         | otherwise = (v,u)
solve n m k as | n == k = Nothing
solve n m k as = if length es == m then Just es else Nothing
    where
    u : l     = [1..n] \\ as
    v : w : _ = as
    e1 = edge u v
    e2 = edge u w
    e3 = edge v w
    es = take m $ [e1,e2] ++
                  [ (i,j) | i <- [1..n], j <- [i+1..n] , i /= v , j /= v, (i,j) /= e2] ++
                  [ edge u' v | u' <- l]

{-# LANGUAGE MultiParamTypeClasses,FlexibleContexts,FlexibleInstances,TypeSynonymInstances,BangPatterns,RankNTypes #-}

import Control.Monad
import Control.Monad.ST
import Control.Applicative
import Control.Arrow
import Debug.Trace

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

readInt = B.readInt >>> fmap fst >>> fromMaybe 0
readsInt = map readInt . B.words <$> B.getLine
readLine :: Read a => IO a
readLine = read <$> getLine
readsLine :: Read a => IO [a]
readsLine = map read . words <$> getLine

cmpFst (a,_) (b,_) = compare a b
cmpSnd (_,a) (_,b) = compare a b
cmpLen a b = length a `compare` length b

swap (a,b) = (b,a)
rect a b = rect2 0 0 a b
rect2 i j a b = ((i,j),(a,b))

itof :: Int -> Double
itof = fromIntegral
casti = fromIntegral

maximize f l = snd $ maximumBy cmpFst [(f x,x) | x <- l]
minimize f l = snd $ minimumBy cmpFst [(f x,x) | x <- l]

infixr 2 <||>
infixr 3 <&&>
p1 <||> p2 = (p1 &&& p2) >>> uncurry (||)
p1 <&&> p2 = (p1 &&& p2) >>> uncurry (&&)

main = do
    [n,m,k] <- readsLine
    as      <- readsLine
    case solve n m k as of
        Nothing -> print (-1)
        Just es -> forM_ es $ \(s,t) ->
            putStrLn $ show s ++ " " ++ show t

edge u v | u <= v = (u,v)
         | otherwise = (v,u)
solve n m k as | n == k = Nothing
solve n m k as = if length es == m then Just es else Nothing
    where
    u :_  = [1..n] \\ as
    v : w : _ = as
    es = take m $ [edge u v,edge u w] ++ do
         i <- [1..n]
         guard $ i /= v
         j <- [i+1..n]
         guard $ edge u v /= (i,j)
         guard $ edge u w /= (i,j)
         return (i,j)

{-# LANGUAGE MultiParamTypeClasses,FlexibleContexts,FlexibleInstances,TypeSynonymInstances,BangPatterns,RankNTypes #-}

import Control.Monad
import Control.Monad.ST
import Control.Applicative
import Control.Arrow
import Debug.Trace

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

readInt = B.readInt >>> fmap fst >>> fromMaybe 0
readsInt = map readInt . B.words <$> B.getLine
readLine :: Read a => IO a
readLine = read <$> getLine
readsLine :: Read a => IO [a]
readsLine = map read . words <$> getLine

cmpFst (a,_) (b,_) = compare a b
cmpSnd (_,a) (_,b) = compare a b
cmpLen a b = length a `compare` length b

swap (a,b) = (b,a)
rect a b = rect2 0 0 a b
rect2 i j a b = ((i,j),(a,b))

itof :: Int -> Double
itof = fromIntegral
casti = fromIntegral

maximize f l = snd $ maximumBy cmpFst [(f x,x) | x <- l]
minimize f l = snd $ minimumBy cmpFst [(f x,x) | x <- l]

infixr 2 <||>
infixr 3 <&&>
p1 <||> p2 = (p1 &&& p2) >>> uncurry (||)
p1 <&&> p2 = (p1 &&& p2) >>> uncurry (&&)

main = do
    [n,m,k] <- readsLine
    as      <- readsLine
    case solve n m k as of
        Nothing -> print (-1)
        Just es -> forM_ es $ \(s,t) ->
            putStrLn $ show s ++ " " ++ show t

edge u v | u <= v = (u,v)
         | otherwise = (v,u)
solve n m k as | n == k = Nothing
solve n m k as | k == n - 1 = if length es == m then Just es else Nothing
    where
    u :_  = [1..n] \\ as
    v : w : _ = as
    es = take m $ [edge u v,edge u w] ++ do
         i <- [1..n]
         guard $ i /= v
         j <- [i+1..n]
         guard $ edge u v /= (i,j)
         guard $ edge u w /= (i,j)
         return (i,j)
solve n m k as = Just es
    where
    u:v:_ = [1..n] \\ as
    es = take m $ (u,v):[(i,j) | i <- [1..n], j <- [i+1..n], (i,j) /= (u,v)]

{-# LANGUAGE MultiParamTypeClasses,FlexibleContexts,FlexibleInstances,TypeSynonymInstances,BangPatterns,RankNTypes #-}

import Control.Monad
import Control.Monad.ST
import Control.Applicative
import Control.Arrow
import Debug.Trace

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

readInt = B.readInt >>> fmap fst >>> fromMaybe 0
readsInt = map readInt . B.words <$> B.getLine
readLine :: Read a => IO a
readLine = read <$> getLine
readsLine :: Read a => IO [a]
readsLine = map read . words <$> getLine

cmpFst (a,_) (b,_) = compare a b
cmpSnd (_,a) (_,b) = compare a b
cmpLen a b = length a `compare` length b

swap (a,b) = (b,a)
rect a b = rect2 0 0 a b
rect2 i j a b = ((i,j),(a,b))

itof :: Int -> Double
itof = fromIntegral
casti = fromIntegral

maximize f l = snd $ maximumBy cmpFst [(f x,x) | x <- l]
minimize f l = snd $ minimumBy cmpFst [(f x,x) | x <- l]

infixr 2 <||>
infixr 3 <&&>
p1 <||> p2 = (p1 &&& p2) >>> uncurry (||)
p1 <&&> p2 = (p1 &&& p2) >>> uncurry (&&)

main = do
    [n,m,k] <- readsLine
    as      <- readsLine
    case solve n m k as of
        Nothing -> print (-1)
        Just es -> forM_ es $ \(s,t) ->
            putStrLn $ show s ++ " " ++ show t

edge u v | u <= v = (u,v)
         | otherwise = (v,u)
solve n m k as | n == k = Nothing
solve n m k as | k == n - 1 = if length es == m then Just es else Nothing
    where
    u :_  = [1..n] \\ as
    v : w : _ = as
    es = take m $ [edge u v,edge u w] ++ do
         i <- [1..n]
         guard $ i /= v
         j <- [i+1..n]
         guard $ edge u v /= (i,j)
         guard $ edge u w /= (i,j)
         return (i,j)
solve n m k as | m == n * (n-1) `div` 2 = Nothing
               | otherwise = Just es
    where
    u:v:_ = [1..n] \\ as
    w = head as
    es = take m $ [edge u w,edge w v] ++ ([(i,j) | i <- [1..n], j <- [i+1..n]] \\ [edge u v,edge u w,edge w v])


Your city has n junctions. There are m one-way roads between the junctions. As a mayor of the city, you have to ensure the security of all the junctions.To ensure the security, you have to build some police checkposts. Checkposts can only be built in a junction. A checkpost at junction i can protect junction j if either i = j or the police patrol car can go to j from i and then come back to i.Building checkposts costs some money. As some areas of the city are more expensive than others, building checkpost at some junctions might cost more money than other junctions.You have to determine the minimum possible money needed to ensure the security of all the junctions. Also you have to find the number of ways to ensure the security in minimum price and in addition in minimum number of checkposts. Two ways are different if any of the junctions contains a checkpost in one of them and do not contain in the other.

In the first line, you will be given an integer n, number of junctions (1 ≤ n ≤ 105). In the next line, n space-separated integers will be given. The ith integer is the cost of building checkpost at the ith junction (costs will be non-negative and will not exceed 109). The next line will contain an integer m (0 ≤ m ≤ 3·105). And each of the next m lines contains two integers ui and vi (1 ≤ ui, vi ≤ n; u ≠ v). A pair ui, vi means, that there is a one-way road which goes from ui to vi. There will not be more than one road between two nodes in the same direction.

Print two integers separated by spaces. The first one is the minimum possible money needed to ensure the security of all the junctions. And the second one is the number of ways you can ensure the security modulo 1000000007 (109 + 7).

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections, OverloadedStrings #-}
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST (runSTUArray, STArray)
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Function
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S
import Data.STRef
import GHC.Arr (Array, Ix, range, unsafeIndex)
bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs = case B.readInt bs of Just (n,_) -> n
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep !n f=go 0 where go !i=when(i<n)$f i>>go(i+1)
rev !n f=go(n-1)where go !i=when(i>=0)$f i>>go(i-1)
{-# INLINE rep #-}
{-# INLINE rev #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

type Vertex = Int
type Edge = (Vertex, Vertex)
type Graph = Array Vertex [Vertex]
type Path = [Vertex]

mkGraph :: (Int, Int) -> [Edge] -> Graph
mkGraph bnd edges = unsafeAccumArray (flip (:)) [] bnd edges

vertices :: Graph -> [Vertex]
vertices gr = range $ bounds gr

edges :: Graph -> [Edge]
edges gr = [(from, to) | from <- vertices gr, to <- unsafeAt gr from ]

revGraph :: Graph -> Graph
revGraph gr = mkGraph (bounds gr) . map swap $ edges gr
   where
     swap (x,y) = (y,x)

dfsAll :: Graph -> [Vertex] -> [[Vertex]]
dfsAll gr vs = filter (not.null) $ runST $ do
  vis <- newArray (bounds gr) False :: ST s (STUArray s Vertex Bool)
  mapM (dfsM gr vis) vs

dfsM :: Graph -> STUArray s Vertex Bool -> Vertex -> ST s [Vertex]
dfsM gr vis root = do
  let go res (v:vs) = do
        visited <- unsafeRead vis v
        if visited then go res vs
        else do
          unsafeWrite vis v True
          go (v:res) (unsafeAt gr v ++ vs)
      go res [] = return $ reverse res
  go [] [root]

topSort :: Graph -> [Vertex]
topSort gr = runST $ do
  vis   <- newArray (bounds gr) False :: ST s (STUArray s Vertex Bool)
  stack <- newSTRef []                :: ST s (STRef s [Vertex])
  let visit v = do
        visited <- unsafeRead vis v
        unless visited $ do
          unsafeWrite vis v True
          mapM_ visit $ unsafeAt gr v
          modifySTRef stack (v:)
  mapM_ visit $ vertices gr
  readSTRef stack

scc :: Graph -> [[Vertex]]
scc gr = dfsAll gr . topSort $ revGraph gr

main :: IO ()
main = do
  n <- readLn :: IO Int
  costs <- listArray(0,n-1).map readInt.B.words <$> B.getLine
  m <- readLn :: IO Int
  es <- toEdges.map(subtract 1.readInt).B.words <$> B.getContents
  putStrLn.unwords.map show $ solve n m costs es

toEdges (x:y:xys) = x`seq`y`seq`((x,y) : toEdges xys)
toEdges _ = []

solve :: Int -> Int -> UArray Int Int -> [Edge] -> [Integer]
solve n m costs es = [minCost, num]
   where
     vss = map (minimums.map(unsafeAt costs)).scc $ mkGraph (0,n-1) es
     minCost = sum $ map (toInteger.head) vss
     num = foldl'(\x y -> x*toInteger y `rem` 1000000007) 1 $ map length vss
     minimums xs = filter (x==) xs
      where
        !x = minimum xs

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections, OverloadedStrings #-}
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST (runSTUArray, STArray)
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Function
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S
import Data.STRef
import GHC.Arr (Array, Ix, range, unsafeIndex)
bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs = case B.readInt bs of Just (n,_) -> n
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep !n f=go 0 where go !i=when(i<n)$f i>>go(i+1)
rev !n f=go(n-1)where go !i=when(i>=0)$f i>>go(i-1)
{-# INLINE rep #-}
{-# INLINE rev #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

type Vertex = Int
type Edge = (Vertex, Vertex)
type Graph = Array Vertex [Vertex]
type Path = [Vertex]

mkGraph :: (Int, Int) -> [Edge] -> Graph
mkGraph bnd edges = unsafeAccumArray (flip (:)) [] bnd edges

vertices :: Graph -> [Vertex]
vertices gr = range $ bounds gr

edges :: Graph -> [Edge]
edges gr = [(from, to) | from <- vertices gr, to <- unsafeAt gr from ]

revGraph :: Graph -> Graph
revGraph gr = mkGraph (bounds gr) . map swap $ edges gr
   where
     swap (x,y) = (y,x)

dfsAll :: Graph -> [Vertex] -> [[Vertex]]
dfsAll gr vs = filter (not.null) $ runST $ do
  vis <- newArray (bounds gr) False :: ST s (STUArray s Vertex Bool)
  mapM (dfsM gr vis) vs

dfsM :: Graph -> STUArray s Vertex Bool -> Vertex -> ST s [Vertex]
dfsM gr vis root = do
  let go res (v:vs) = do
        visited <- unsafeRead vis v
        if visited then go res vs
        else do
          unsafeWrite vis v True
          go (v:res) (unsafeAt gr v ++ vs)
      go res [] = return $ reverse res
  go [] [root]

topSort :: Graph -> [Vertex]
topSort gr = runST $ do
  vis   <- newArray (bounds gr) False :: ST s (STUArray s Vertex Bool)
  stack <- newSTRef []                :: ST s (STRef s [Vertex])
  let visit v = do
        visited <- unsafeRead vis v
        unless visited $ do
          unsafeWrite vis v True
          mapM_ visit $ unsafeAt gr v
          modifySTRef stack (v:)
  mapM_ visit $ vertices gr
  readSTRef stack

scc :: Graph -> [[Vertex]]
scc gr = dfsAll gr . topSort $ revGraph gr

main :: IO ()
main = do
  n <- readLn :: IO Int
  costs <- listArray(0,n-1).map readInt.B.words <$> B.getLine
  m <- readLn :: IO Int
  es <- toEdges.map(subtract 1.readInt).B.words <$> B.getContents
  putStrLn.unwords.map show $ solve n m costs es

toEdges (x:y:xys) = x`seq`y`seq`((x,y) : toEdges xys)
toEdges _ = []

solve :: Int -> Int -> UArray Int Int -> [Edge] -> [Int]
solve n m costs es = [minCost, num]
   where
     vss = map (minimums.map(unsafeAt costs)).scc $ mkGraph (0,n-1) es
     minCost = sum $ map head vss
     num = foldl'(\x y -> x*y `rem` 1000000007) 1 $ map length vss
     minimums xs = filter (x==) xs
      where
        !x = minimum xs


Let's denote as  the number of bits set ('1' bits) in the binary representation of the non-negative integer x.You are given multiple queries consisting of pairs of integers l and r. For each query, find the x, such that l ≤ x ≤ r, and  is maximum possible. If there are multiple such numbers find the smallest of them.

The first line contains integer n — the number of queries (1 ≤ n ≤ 10000). Each of the following n lines contain two integers li, ri — the arguments for the corresponding query (0 ≤ li ≤ ri ≤ 1018).

For each query print the answer in a separate line.

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

{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import Control.Monad
import Control.Monad.ST.Safe
import Control.Monad.State
import Data.Array
-- import Data.Array.IArray
import Data.Array.IO.Safe
import Data.Array.MArray.Safe
import Data.Array.ST.Safe
-- import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Builder as BB
import Data.Char
import Data.Function
-- import Data.Graph
import Data.Int
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
-- import Data.Tree
import Data.Tuple
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import System.IO
-- import Debug.Trace

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

f l r
  | l == r = l
  | p <= l = f (l-p) (r-p) + p
  | 2*p-1 <= r = 2*p-1
  | otherwise = p-1
  where
    p = last $ takeWhile (<= r) $ map (2^) [0..]

main = do
  n <- readLn
  replicateM n (do
    [l, r] <- getInts :: IO [Int64]
    print $ f l r)

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, TupleSections, OverloadedStrings #-}
import Control.Applicative
import Control.Exception hiding (mask)
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST (runSTUArray, runSTArray)
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Function
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.IntMap as IM
import qualified Data.Set as S
import qualified Data.IntSet as IS
import Data.STRef
import GHC.Arr (Array, STArray, Ix(..))
import Debug.Trace

bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInteger :: B.ByteString -> Integer
readInteger bs=case B.readInteger bs of{Just(n,_)->n;_->error$"readInt error : bs = "++show bs;}
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep n f=foldr((>>).f)(return())[0..n-1]
rev n f=foldr((>>).f.negate)(return())[1-n..0]
for :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
for a b f=foldr((>>).f)(return())[a..b]
{-# INLINE rep #-}
{-# INLINE rev #-}
{-# INLINE for #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

main :: IO ()
main = do
  (n:lrs) <- map (fromIntegral.readInteger).B.words <$> B.getContents
  putStr.unlines.map show $ solve lrs

solve :: [Int64] -> [Int64]
solve lrs = go lrs
   where
     go (l:r:lrs) = query l r : go lrs
     go _ = []

query :: Int64 -> Int64 -> Int64
query l r
  | l == r = l
  | l<=cand = cand
  | otherwise = h + query (l-h) (r-h)
   where
     cand = last . takeWhile (<=r) $ iterate (\acc->acc*2+1) 0
     h = cand `xor` unsafeShiftR cand 1


A team of students from the city S is sent to the All-Berland Olympiad in Informatics. Traditionally, they go on the train. All students have bought tickets in one carriage, consisting of n compartments (each compartment has exactly four people). We know that if one compartment contain one or two students, then they get bored, and if one compartment contain three or four students, then the compartment has fun throughout the entire trip.The students want to swap with other people, so that no compartment with students had bored students. To swap places with another person, you need to convince him that it is really necessary. The students can not independently find the necessary arguments, so they asked a sympathetic conductor for help. The conductor can use her life experience to persuade any passenger to switch places with some student.However, the conductor does not want to waste time persuading the wrong people, so she wants to know what is the minimum number of people necessary to persuade her to change places with the students. Your task is to find the number. After all the swaps each compartment should either have no student left, or have a company of three or four students.

The first line contains integer n (1 ≤ n ≤ 106) — the number of compartments in the carriage. The second line contains n integers a1, a2, ..., an showing how many students ride in each compartment (0 ≤ ai ≤ 4). It is guaranteed that at least one student is riding in the train.

If no sequence of swapping seats with other people leads to the desired result, print number "-1" (without the quotes). In another case, print the smallest number of people you need to persuade to swap places.

{-# LANGUAGE BangPatterns #-}
import Data.Maybe (fromJust)
import Data.ByteString (ByteString)
import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Array.Unboxed (UArray, accumArray, elems)

-- 1, 2, 3, 4
loop :: Int -> Int -> Int -> Int -> Int
loop 0 0 _ _ = 0

-- 50% gain
loop i j k l --  1 -> 2
    | 0 < i && 0 < j = inc + loop (i - inc) (j - inc) (k + inc) l
    where inc = min i j

-- 1/3rd gain
loop i 0 k l -- {1, 1, 1}
    | 2 < i = inc * 2 + loop (i - 3 * inc) 0 (k + inc) l
    where inc = i `div` 3

-- 1/3rd gain
loop 0 j k l -- 2, 2, 2 -> 3, 3
    | 2 < j = inc * 2 + loop 0 (j - 3 * inc) (k + 2 * inc) l
    where inc = j `div` 3

loop 1 0 0 _ = 2  -- 1, 4, 4 -> 3, 3
loop 1 0 _ _ = 1  -- 1 -> 3
loop 2 0 _ _ = 2

loop 0 1 _ 0 = 2
loop 0 1 _ _ = 1
loop 0 2 _ _ = 2

solve :: [Int] -> Int
solve a
    | acc < 3 || acc == 5 = -1
    | otherwise = loop i j k l
    where
    arr :: UArray Int Int
    arr = accumArray (+) 0 (0, 4) . zip a . repeat $ 1
    [i, j, k, l] = tail $ elems arr
    acc = sum a

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

main = B.getLine >> parse <$> B.getLine >>= print . solve

{-# LANGUAGE BangPatterns #-}
import Data.Maybe (fromJust)
import Data.ByteString (ByteString)
import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Array.Unboxed (UArray, accumArray, elems)
import Debug.Trace (traceShow)

-- 1, 2, 3, 4
loop :: Int -> Int -> Int -> Int -> Int
loop 0 0 _ _ = 0

loop i j k l --  1 -> 2
    | 0 < i && 0 < j = inc + loop (i - inc) (j - inc) (k + inc) l
    where inc = min i j

loop i 0 k l -- {1, 1, 1}
    | 2 < i = inc * 2 + loop (i - 3 * inc) 0 (k + inc) l
    where inc = i `div` 3

loop 1 0 0 _ = 2  -- 1, 4, 4 -> 3, 3
loop 1 0 _ _ = 1  -- 1 -> 3
loop 2 0 _ _ = 2

loop 0 j k l -- 2, 2, 2 -> 3, 3
    | 2 < j = inc * 2 + loop 0 (j - 3 * inc) (k + 2 * inc) l
    where inc = j `div` 3

loop 0 1 _ 0 = 2
loop 0 1 _ _ = 1
loop 0 2 _ _ = 2

solve :: [Int] -> Int
solve a = if acc < 3 || acc == 5 then -1 else loop i j k l
    where
    arr :: UArray Int Int
    arr = accumArray (+) 0 (0, 4) . zip a . repeat $ 1
    [i, j, k, l] = tail $ elems arr
    acc = sum a

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

main = B.getLine >> parse <$> B.getLine >>= print . solve

{-# LANGUAGE BangPatterns #-}
import Data.Maybe (fromJust)
import Data.ByteString (ByteString)
import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Array.Unboxed (UArray, accumArray, elems, (!))
import Debug.Trace (traceShow)

-- 1, 2, 3, 4
loop :: Int -> Int -> Int -> Int -> Int
loop 0 0 _ _ = 0
loop i j k l --  1 -> 2
    | 0 < i && 0 < j = inc + loop (i - inc) (j - inc) (k + inc) l
    where inc = min i j

loop i 0 k l -- {1, 1, 1}
    | 2 < i = inc * 2 + loop (i - 3 * inc) 0 inc l
    where inc = i `div` 3

loop i 0 k l -- {1, 1, 1, 1}
    | 3 < i = inc * 3 + loop (i - 4 * inc) 0 0 (l + inc)
    where inc = i `div` 4

loop i 0 k l --  1 -> 3
    | 0 < k = inc + loop (i - inc) 0 (k - inc) (l + inc)
    where inc = min i k

loop i 0 _ _ = 2 -- 1, 2

loop 0 j k l -- 2, 2, 2 -> 3, 3
    | 2 < j = inc * 2 + loop 0 (j - 3 * inc) (k + 2 * inc) l
    where inc = j `div` 3

loop 0 1 _ l = if 0 < l then 1 else 2
loop 0 2 _ _ = 2

--loop 0 j k l --  4 -> 2
--    | 0 < j && 0 < l = inc + loop 0 (j - inc) (k + inc) (l - inc)
--    where inc = min j l

solve :: [Int] -> Int
solve a = if sum (elems arr) < 3 then -1 else loop i j k l
    where
    arr :: UArray Int Int
    arr = accumArray (+) 0 (0, 4) . zip a . repeat $ 1
    [i, j, k, l] = map (arr !) [1, 2, 3, 4]

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

main = B.getLine >> parse <$> B.getLine >>= print . solve

{-# LANGUAGE BangPatterns #-}
import Data.Maybe (fromJust)
import Data.ByteString (ByteString)
import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Array.Unboxed (UArray, accumArray, elems)
import Debug.Trace (traceShow)

-- 1, 2, 3, 4
loop :: Int -> Int -> Int -> Int -> Int
loop 0 0 _ _ = 0

loop i j k l --  1 -> 2
    | 0 < i && 0 < j = inc + loop (i - inc) (j - inc) (k + inc) l
    where inc = min i j

loop i 0 k l -- {1, 1, 1}
    | 2 < i = inc * 2 + loop (i - 3 * inc) 0 (k + inc) l
    where inc = i `div` 3

loop 1 0 0 _ = 2  -- 1, 4, 4 -> 3, 3
loop 1 0 _ _ = 1  -- 1 -> 3
loop 2 0 _ _ = 2

loop 0 j k l -- 2, 2, 2 -> 3, 3
    | 2 < j = inc * 2 + loop 0 (j - 3 * inc) (k + 2 * inc) l
    where inc = j `div` 3

loop 0 1 _ 0 = 2
loop 0 1 _ _ = 1
loop 0 2 _ _ = 2

solve :: [Int] -> Int
solve a = if acc < 3 || acc == 5 then -1 else loop i j k l
    where
    arr :: UArray Int Int
    arr = accumArray (+) 0 (0, 4) . zip a . repeat $ 1
    [i, j, k, l] = tail $ elems arr
    acc = sum . tail $ elems arr

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

main = B.getLine >> parse <$> B.getLine >>= print . solve

{-# LANGUAGE BangPatterns #-}
import Data.Maybe (fromJust)
import Data.ByteString (ByteString)
import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Array.Unboxed (UArray, accumArray, elems, (!))
import Debug.Trace (traceShow)

-- 1, 2, 3, 4
loop :: Int -> Int -> Int -> Int -> Int
loop 0 0 _ _ = 0
loop i j k l --  1 -> 2
    | 0 < i && 0 < j = inc + loop (i - inc) (j - inc) (k + inc) l
    where inc = min i j

loop i 0 k l -- {1, 1, 1}
    | 2 < i = inc * 2 + loop (i - 3 * inc) 0 inc l
    where inc = i `div` 3

loop i 0 k l -- {1, 1, 1, 1}
    | 3 < i = inc * 3 + loop (i - 4 * inc) 0 0 (l + inc)
    where inc = i `div` 4

loop i j k l --  1 -> 3
    | 0 < i && 0 < k = inc + loop (i - inc) j (k - inc) (l + inc)
    where inc = min i k

loop i 0 0 _ = i -- 1, 2

loop 0 j k l -- 2, 2, 2 -> 3, 3
    | 2 < j = inc * 2 + loop 0 (j - 3 * inc) (k + 2 * inc) l
    where inc = j `div` 3

loop 0 1 _ l = if 0 < l then 1 else 2
loop 0 2 _ _ = 2

--loop 0 j k l --  4 -> 2
--    | 0 < j && 0 < l = inc + loop 0 (j - inc) (k + inc) (l - inc)
--    where inc = min j l

solve :: [Int] -> Int
solve a = if sum (elems arr) < 3 then -1 else loop i j k l
    where
    arr :: UArray Int Int
    arr = accumArray (+) 0 (0, 4) . zip a . repeat $ 1
    [i, j, k, l] = map (arr !) [1, 2, 3, 4]

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

main = B.getLine >> parse <$> B.getLine >>= print . solve

{-# LANGUAGE BangPatterns #-}
import Data.Maybe (fromJust)
import Data.ByteString (ByteString)
import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Array.Unboxed (UArray, accumArray, elems)
import Debug.Trace (traceShow)

-- 1, 2, 3, 4
loop :: Int -> Int -> Int -> Int -> Int
loop 0 0 _ _ = 0
loop i j k l --  1 -> 2
    | 0 < i && 0 < j = inc + loop (i - inc) (j - inc) (k + inc) l
    where inc = min i j

loop i 0 k l -- {1, 1, 1}
    | 2 < i = inc * 2 + loop (i - 3 * inc) 0 (k + inc) l
    where inc = i `div` 3

-- loop i 0 k l -- {1, 1, 1, 1}
--     | 3 < i = inc * 3 + loop (i - 4 * inc) 0 0 (l + inc)
--     where inc = i `div` 4

loop i 0 k l --  1 -> 3
    | 0 < k = inc + loop (i - inc) 0 (k - inc) (l + inc)
    where inc = min i k

loop i 0 _ _ = 2 -- 1, 2

loop 0 j k l -- 2, 2, 2 -> 3, 3
    | 2 < j = inc * 2 + loop 0 (j - 3 * inc) (k + 2 * inc) l
    where inc = j `div` 3

loop 0 1 _ l = if 0 < l then 1 else 2
loop 0 2 _ _ = 2

--loop 0 j k l --  4 -> 2
--    | 0 < j && 0 < l = inc + loop 0 (j - inc) (k + inc) (l - inc)
--    where inc = min j l

solve :: [Int] -> Int
solve a = (elems arr) `traceShow` if sum (elems arr) < 3 then -1 else loop i j k l
    where
    arr :: UArray Int Int
    arr = accumArray (+) 0 (0, 4) . zip a . repeat $ 1
    [i, j, k, l] = tail $ elems arr

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

main = B.getLine >> parse <$> B.getLine >>= print . solve


Let $$$LCM(x, y)$$$ be the minimum positive integer that is divisible by both $$$x$$$ and $$$y$$$. For example, $$$LCM(13, 37) = 481$$$, $$$LCM(9, 6) = 18$$$.You are given two integers $$$l$$$ and $$$r$$$. Find two integers $$$x$$$ and $$$y$$$ such that $$$l \le x < y \le r$$$ and $$$l \le LCM(x, y) \le r$$$.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 10000$$$) — the number of test cases. Each test case is represented by one line containing two integers $$$l$$$ and $$$r$$$ ($$$1 \le l < r \le 10^9$$$).

For each test case, print two integers:   if it is impossible to find integers $$$x$$$ and $$$y$$$ meeting the constraints in the statement, print two integers equal to $$$-1$$$;  otherwise, print the values of $$$x$$$ and $$$y$$$ (if there are multiple valid answers, you may print any of them).

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

main = getLine >>= flip replicateM_ test . read

test = do
  [l, r] <- map read . words <$> getLine
  if l * 2 > r then putStrLn "-1 -1" else putStrLn $ show l ++ " " ++ show (2 * l)

module Main where

solve [x,y] = if y < x*2 then "-1 -1" else show x ++ " " ++ show (x*2)
main = interact $ unlines . map (solve . map (read :: String -> Int) . words )  . tail . lines

module Main where

   solve :: IO ()
   solve = do
       s <- getLine
       let [l, r] = map (\x -> read x :: Integer) $ words s
       putStrLn $ if 2 * l > r then
           "-1 -1"
       else
           show l ++ " " ++ show (2 * l)

   iter :: Integer -> IO ()
   iter 1 = solve
   iter n = do
       solve
       iter $ n - 1

   main :: IO ()
   main = do
       s <- getLine
       iter (read s :: Integer)

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

onecase = do
		[x,y]<- map read <$> words <$> getLine ::IO [Int]
		putStrLn $ if x+x<=y then intercalate " " (map show [x,x+x]) else "-1 -1"

main= do
		a<- read <$> getLine ::IO Int
		replicateM_ a onecase

type Pair = (Integer, Integer)

parse :: String -> [Pair]
parse = chunksTwo . tail . map read . words

chunksTwo :: [Integer] -> [Pair]
chunksTwo [] = []
chunksTwo (x0:x1:xs) = (x0, x1) : chunksTwo xs
chunksTwo _ = error "malformed input"

solveCase :: Pair -> Pair
solveCase (le, ri)
  | le * 2 > ri  = (0-1, 0-1)
  | otherwise    = (le, 2*le)

displayAns :: Pair -> String
displayAns (x, y) = show x ++ " " ++ show y

main :: IO ()
main = interact (unlines . map (displayAns . solveCase) . parse)

module Main where

solve [x,y] =
    let b = filter (\(_,z) -> z >= x && z <= y) $ let a = [x+1 .. min y (x*2)] in zip a $ map (lcm x) a
    in   if null b
            then "-1 -1"
            else show x ++ " " ++ show (fst $ head b)
main = interact $ unlines . map (solve . map (read :: String -> Int) . words )  . tail . lines

module Main where

solve [x,y] = if y > x*2 then "-1 -1" else show x ++ " " ++ show (x*2)
main = interact $ unlines . map (solve . map (read :: String -> Int) . words )  . tail . lines


Ann and Borya have n piles with candies and n is even number. There are ai candies in pile with number i.Ann likes numbers which are square of some integer and Borya doesn't like numbers which are square of any integer. During one move guys can select some pile with candies and add one candy to it (this candy is new and doesn't belong to any other pile) or remove one candy (if there is at least one candy in this pile). Find out minimal number of moves that is required to make exactly n / 2 piles contain number of candies that is a square of some integer and exactly n / 2 piles contain number of candies that is not a square of any integer.

First line contains one even integer n (2 ≤ n ≤ 200 000) — number of piles with candies. Second line contains sequence of integers a1, a2, ..., an (0 ≤ ai ≤ 109) — amounts of candies in each pile.

Output minimal number of steps required to make exactly n / 2 piles contain number of candies that is a square of some integer and exactly n / 2 piles contain number of candies that is not a square of any integer. If condition is already satisfied output 0.

NoteIn first example you can satisfy condition in two moves. During each move you should add one candy to second pile. After it size of second pile becomes 16. After that Borya and Ann will have two piles with number of candies which is a square of integer (second and fourth pile) and two piles with number of candies which is not a square of any integer (first and third pile).In second example you should add two candies to any three piles.

{-# OPTIONS_GHC -O3 #-}
{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}

import qualified Data.ByteString as B (getLine)
import qualified Data.ByteString.Char8 as C (readInt, words)
import qualified Data.Maybe as M (fromJust)
import qualified Data.List as L (sort, splitAt)
import qualified Data.Int as I (Int64)

readInt = fst . M.fromJust . C.readInt

bin a b x | b - a <= 1 = if abs (a * a - x) > abs (b * b - x) then b * b else a * a
          | m * m <= x = bin m b x | otherwise = bin a m x where m = (a + b) `div` 2

main = do
    (readInt -> n) <- B.getLine
    (map readInt . C.words -> xs) <- B.getLine
    let (map fromIntegral -> as :: [I.Int64], bs) = L.splitAt (n `div` 2) $ L.sort $ zipWith (\x y -> abs (x - y)) (map (bin 0 31700) xs) xs
        zs = length $ filter (== 0) xs
    if zs <= n `div` 2 then
        putStrLn $ show $ sum as + fromIntegral (length (filter (== 0) bs))
    else
        putStrLn $ show $ length (filter (== 0) bs) + (zs - (n `div` 2))

{-# OPTIONS_GHC -O3 #-}
{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}

import qualified Data.ByteString as B (getLine)
import qualified Data.ByteString.Char8 as C (readInt, words)
import qualified Data.Maybe as M (fromJust)
import qualified Data.List as L (sort, splitAt)

readInt = fst . M.fromJust . C.readInt

bin a b x | b - a <= 1 = if abs (a * a - x) > abs (b * b - x) then b * b else a * a
          | m * m <= x = bin m b x | otherwise = bin a m x where m = (a + b) `div` 2

main = do
    (readInt -> n) <- B.getLine
    (map readInt . C.words -> xs) <- B.getLine
    let (as, bs) = L.splitAt (n `div` 2) $ L.sort $ zipWith (\x y -> abs (x - y)) (map (bin 0 31700) xs) xs
        zs = length $ filter (== 0) xs
    if zs <= n `div` 2 then
        putStrLn $ show $ sum as + length (filter (== 0) bs)
    else
        putStrLn $ show $ length (filter (== 0) bs) + (zs - (n `div` 2))

{-# OPTIONS_GHC -O3 #-}
{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}

import qualified Data.ByteString as B (getLine)
import qualified Data.ByteString.Char8 as C (readInt, words)
import qualified Data.Maybe as M (fromJust)
import qualified Data.List as L (sort, splitAt)

readInt = fst . M.fromJust . C.readInt

bin a b x | b - a <= 1 = if abs (a * a - x) > abs (b * b - x) then b * b else a * a
          | m * m <= x = bin m b x | otherwise = bin a m x where m = (a + b) `div` 2

main = do
    (readInt -> n) <- B.getLine
    (map readInt . C.words -> xs) <- B.getLine
    let (as, bs) = L.splitAt (n `div` 2) $ L.sort $ zipWith (\x y -> abs (x - y)) (map (bin 0 100000) xs) xs
        zs = length $ filter (== 0) xs
    if zs <= n `div` 2 then
        putStrLn $ show $ sum as + length (filter (== 0) bs)
    else
        putStrLn $ show $ length (filter (== 0) bs) + (zs - (n `div` 2))


Masha has $$$n$$$ types of tiles of size $$$2 \times 2$$$. Each cell of the tile contains one integer. Masha has an infinite number of tiles of each type.Masha decides to construct the square of size $$$m \times m$$$ consisting of the given tiles. This square also has to be a symmetric with respect to the main diagonal matrix, and each cell of this square has to be covered with exactly one tile cell, and also sides of tiles should be parallel to the sides of the square. All placed tiles cannot intersect with each other. Also, each tile should lie inside the square. See the picture in Notes section for better understanding.Symmetric with respect to the main diagonal matrix is such a square $$$s$$$ that for each pair $$$(i, j)$$$ the condition $$$s[i][j] = s[j][i]$$$ holds. I.e. it is true that the element written in the $$$i$$$-row and $$$j$$$-th column equals to the element written in the $$$j$$$-th row and $$$i$$$-th column.Your task is to determine if Masha can construct a square of size $$$m \times m$$$ which is a symmetric matrix and consists of tiles she has. Masha can use any number of tiles of each type she has to construct the square. Note that she can not rotate tiles, she can only place them in the orientation they have in the input.You have to answer $$$t$$$ independent test cases.

The first line of the input contains one integer $$$t$$$ ($$$1 \le t \le 100$$$) — the number of test cases. Then $$$t$$$ test cases follow. The first line of the test case contains two integers $$$n$$$ and $$$m$$$ ($$$1 \le n \le 100$$$, $$$1 \le m \le 100$$$) — the number of types of tiles and the size of the square Masha wants to construct. The next $$$2n$$$ lines of the test case contain descriptions of tiles types. Types of tiles are written one after another, each type is written on two lines.  The first line of the description contains two positive (greater than zero) integers not exceeding $$$100$$$ — the number written in the top left corner of the tile and the number written in the top right corner of the tile of the current type. The second line of the description contains two positive (greater than zero) integers not exceeding $$$100$$$ — the number written in the bottom left corner of the tile and the number written in the bottom right corner of the tile of the current type. It is forbidden to rotate tiles, it is only allowed to place them in the orientation they have in the input.

For each test case print the answer: "YES" (without quotes) if Masha can construct the square of size $$$m \times m$$$ which is a symmetric matrix. Otherwise, print "NO" (withtout quotes).

NoteThe first test case of the input has three types of tiles, they are shown on the picture below.  Masha can construct, for example, the following square of size $$$4 \times 4$$$ which is a symmetric matrix:

import Control.Monad

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

main :: IO ()
main = do
  t <- read <$> getLine
  replicateM_ t $ do
    [n, m] <- readInts
    symms <- replicateM n $ do
      [_, p] <- readInts
      [q, _] <- readInts
      pure $ p == q
    putStrLn $ if  even m && or symms
      then  "YES"
      else  "NO"

import Control.Arrow ( (>>>) )

main :: IO ()
main = interact $
  lines >>> drop 1
  >>> map (words >>> map read)
  >>> process
  >>> map (\x -> if x then "YES" else "NO") >>> unlines

process :: [[Int]] -> [Bool]
process [] = []
process ([n, m] : rest) =
  (if m `mod` 2 == 0 then solve (take (n*2) rest) else False) : process (drop (n*2) rest)

solve :: [[Int]] -> Bool
solve [] = False
solve ([_, a]:[b, _]:rest) = or [a == b, solve rest]

import Control.Monad
import Data.Char
import Data.List

getList :: (Read t) => IO [t]
getList = getLine >>= return . (map read) . words

getOne :: (Read t) => IO t
getOne = getLine >>= return . read

main :: IO ()
main = do
  t <- getOne
  -- let t = 1
  replicateM_ t solve

solve :: IO ()
solve = do
  [n, m] <- getList
  plits <- replicateM n scanOne
  putStrLn $ countAns m plits
  where
    scanOne :: IO [Int]
    scanOne = do
      a <- getList
      b <- getList
      return $ a ++ b

countAns :: Integral t => t -> [[t]]-> String
countAns m plits
  | m `mod` 2 == 1 = "NO"
  | not $ any (\l -> (l !! 1) == (l !! 2)) plits = "NO"
  | null $ intersect plits $ map rev plits = "NO"
  | otherwise = "YES"
  where
    rev :: Integral t => [t] -> [t]
    rev [a, b, c, d] = [a, c, b, d]

third :: [Int] -> Int
third a = head (tail (tail a))

getAns :: Int -> [[Int]] -> Bool
getAns m [] = False
getAns m a | mod m 2 /= 0 = False
           | (head (tail (head a))) == (third (head a)) = True
           | otherwise = getAns m (tail a)

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

get :: Int -> [String] -> Int
get 0 a = read (head (a)) :: Int
get 1 a = read (head (tail (a))) :: Int

getList :: Int -> [[Int]] -> Int -> IO()
getList 0 a m = do
    putStrLn (convert (getAns m a))

getList n a m = do
    first <- getLine
    second <- getLine

    let list = [(get 0 (words first)), (get 1 (words first)), (get 0 (words second)), (get 1 (words second))]
    getList (n - 1) (a ++ [list]) m

solve :: Int -> IO()
solve 0 = do
    putStr ""
solve t = do
    str <- getLine
    let n = get 0 (words str)
    let m = get 1 (words str)
    getList n [] m
    solve (t - 1)

main = do
    testes <- getLine
    let t = read testes :: Int
    solve t

import           Control.Monad       (replicateM_, replicateM)

data Tile =
    Tile Int Int Int Int

data Input =
    Input Int Int [Tile]

readT :: IO Int
readT = do
    line <- getLine
    pure (read line :: Int)

isSymmetric :: Tile -> Bool
isSymmetric (Tile a b c d) | b == c    = True
                           | otherwise = False

oppositeTile :: Tile -> Tile
oppositeTile (Tile a b c d) = Tile a c b d

hasSymmetricTile :: [Tile] -> Bool
hasSymmetricTile = any isSymmetric

canBeSolved :: Input -> Bool
canBeSolved (Input n m tiles) | odd m      = False
                              | otherwise  = hasSymmetricTile tiles

readTuple :: IO (Int, Int)
readTuple = do
    num_strings <- words <$> getLine
    let a = read (head num_strings) :: Int
    let b = read (last num_strings) :: Int
    pure (a, b)

readTile :: IO Tile
readTile = do
    (a, b) <- readTuple
    (c, d) <- readTuple

    let tile = Tile a b c d
    pure tile

readInput :: IO Input
readInput = do
    (n, m) <- readTuple
    tiles <- replicateM n readTile
    pure (Input n m tiles)

solveCase :: IO ()
solveCase = do
    input <- readInput

    let ans | canBeSolved input = "YES"
            | otherwise         = "NO"

    putStrLn ans

main :: IO ()
main = do
    t <- readT
    replicateM_ t solveCase

-- vim: set ts=4 sw=4 expandtab:


It is a complicated version of problem F1. The difference between them is the constraints (F1: $$$k \le 2$$$, F2: $$$k \le 10$$$).You are given an integer $$$n$$$. Find the minimum integer $$$x$$$ such that $$$x \ge n$$$ and the number $$$x$$$ is $$$k$$$-beautiful.A number is called $$$k$$$-beautiful if its decimal representation having no leading zeroes contains no more than $$$k$$$ different digits. E.g. if $$$k = 2$$$, the numbers $$$3434443$$$, $$$55550$$$, $$$777$$$ and $$$21$$$ are $$$k$$$-beautiful whereas the numbers $$$120$$$, $$$445435$$$ and $$$998244353$$$ are not.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of test cases. Then $$$t$$$ test cases follow. Each test case consists of one line containing two integers $$$n$$$ and $$$k$$$ ($$$1 \le n \le 10^9$$$, $$$1 \le k \le 10$$$).

For each test case output on a separate line $$$x$$$ — the minimum $$$k$$$-beautiful integer such that $$$x \ge n$$$.

import Data.List (group, sort)

main :: IO ()
main = interact processInput

processInput :: String -> String
processInput input = output
    where
        tests = drop 1 $ lines input
        answers = map processTest tests
        output = unlines answers

processTest :: String -> String
processTest input = output
    where
        [n, k] = map read $ words input
        result = findFirstKBeautifulNumber n (fromIntegral k)
        output = show result

findFirstKBeautifulNumber :: Integer -> KParameter -> Integer
findFirstKBeautifulNumber start k
    | isKBeautiful start k = start
    | start `mod` 10 /= 0 = findFirstKBeautifulNumber (start + 1) k
    | otherwise = result_if_start_ends_with_zero
    where
        result_if_start_ends_with_zero = result_for_short_version * 10 + last_digit
        result_for_short_version = findFirstKBeautifulNumber (start `div` 10) k
        last_digit = read [minimum (show result_for_short_version)]

isKBeautiful :: Integer -> KParameter -> Bool
isKBeautiful number k = measureK number <= k

type KParameter = Int
measureK :: Integer -> KParameter
measureK = length . group . sort . show

import Data.List (group, sort)

main :: IO ()
main = interact processInput

processInput :: String -> String
processInput input = output
    where
        tests = drop 1 $ lines input
        answers = map processTest tests
        output = unlines answers

processTest :: String -> String
processTest input = output
    where
        [n, k] = map read $ words input
        result = findFirstKBeautifulNumber n (fromIntegral k)
        output = show result

findFirstKBeautifulNumber :: Integer -> KParameter -> Integer
findFirstKBeautifulNumber start k
    | isKBeautiful start k = start
    | start `mod` 10 /= 0 = findFirstKBeautifulNumber (start + 1) k
    | otherwise = result_if_start_ends_with_zero
    where
        result_if_start_ends_with_zero = result_for_short_version * 10 + last_digit
        result_for_short_version = findFirstKBeautifulNumber (start `div` 10) k
        can_add_new_digit = measureK result_for_short_version < k
        last_digit = if can_add_new_digit then 0 else read [minimum (show result_for_short_version)]

isKBeautiful :: Integer -> KParameter -> Bool
isKBeautiful number k = measureK number <= k

type KParameter = Int
measureK :: Integer -> KParameter
measureK = length . group . sort . show


You helped Dima to have a great weekend, but it's time to work. Naturally, Dima, as all other men who have girlfriends, does everything wrong.Inna and Dima are now in one room. Inna tells Dima off for everything he does in her presence. After Inna tells him off for something, she goes to another room, walks there in circles muttering about how useless her sweetheart is. During that time Dima has time to peacefully complete k - 1 tasks. Then Inna returns and tells Dima off for the next task he does in her presence and goes to another room again. It continues until Dima is through with his tasks.Overall, Dima has n tasks to do, each task has a unique number from 1 to n. Dima loves order, so he does tasks consecutively, starting from some task. For example, if Dima has 6 tasks to do in total, then, if he starts from the 5-th task, the order is like that: first Dima does the 5-th task, then the 6-th one, then the 1-st one, then the 2-nd one, then the 3-rd one, then the 4-th one.Inna tells Dima off (only lovingly and appropriately!) so often and systematically that he's very well learned the power with which she tells him off for each task. Help Dima choose the first task so that in total he gets told off with as little power as possible.

The first line of the input contains two integers n, k (1 ≤ k ≤ n ≤ 105). The second line contains n integers a1, a2, ..., an (1 ≤ ai ≤ 103), where ai is the power Inna tells Dima off with if she is present in the room while he is doing the i-th task. It is guaranteed that n is divisible by k.

In a single line print the number of the task Dima should start with to get told off with as little power as possible. If there are multiple solutions, print the one with the minimum number of the first task to do.

NoteExplanation of the first example.If Dima starts from the first task, Inna tells him off with power 3, then Dima can do one more task (as k = 2), then Inna tells him off for the third task with power 1, then she tells him off for the fifth task with power 5. Thus, Dima gets told off with total power 3 + 1 + 5 = 9. If Dima started from the second task, for example, then Inna would tell him off for tasks 2, 4 and 6 with power 2 + 6 + 4 = 12. Explanation of the second example.In the second example k = 5, thus, Dima manages to complete 4 tasks in-between the telling off sessions. Thus, Inna tells Dima off for tasks number 1 and 6 (if he starts from 1 or 6), 2 and 7 (if he starts from 2 or 7) and so on. The optimal answer is to start from task 3 or 8, 3 has a smaller number, so the answer is 3.

import System.IO
import Data.List

calc :: ([Int], [Int]) -> [Int] -> ([Int], [Int])
calc p [] = p
calc ([], r) xs = calc (reverse r, []) xs
calc (y:ys, r) (x:xs) = calc (ys, (y+x):r) xs

solve :: Int -> Int -> [Int] -> Int
solve n k a = find_ind 1 (-1) 0 b
    where
        (l, r) = calc (replicate k 0, []) a
        b = (reverse r) ++ l
        find_ind :: Int -> Int -> Int -> [Int] -> Int
        find_ind _ i _ [] = i
        find_ind i (-1) _ (x:xs) = find_ind (i+1) i x xs
        find_ind i j mj (x:xs)
            | x < mj = find_ind (i+1) i x xs
            | otherwise = find_ind (i+1) j mj xs

main :: IO()
main = do
    [n, k] <- fmap (map read) $ fmap words $ getLine
    a <- fmap (map read) $ fmap words $ getLine
    print $ solve n k a


Pushok the dog has been chasing Imp for a few hours already.  Fortunately, Imp knows that Pushok is afraid of a robot vacuum cleaner. While moving, the robot generates a string t consisting of letters 's' and 'h', that produces a lot of noise. We define noise of string t as the number of occurrences of string "sh" as a subsequence in it, in other words, the number of such pairs (i, j), that i < j and  and . The robot is off at the moment. Imp knows that it has a sequence of strings ti in its memory, and he can arbitrary change their order. When the robot is started, it generates the string t as a concatenation of these strings in the given order. The noise of the resulting string equals the noise of this concatenation.Help Imp to find the maximum noise he can achieve by changing the order of the strings.

The first line contains a single integer n (1 ≤ n ≤ 105) — the number of strings in robot's memory. Next n lines contain the strings t1, t2, ..., tn, one per line. It is guaranteed that the strings are non-empty, contain only English letters 's' and 'h' and their total length does not exceed 105.

Print a single integer — the maxumum possible noise Imp can achieve by changing the order of the strings.

NoteThe optimal concatenation in the first sample is ssshhshhhs.

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

main = do
    n <- getLine >>= return . read
    shc <- replicateM n getLine >>= return . (map countSHC)
    print $ (sum $ map (\(_, _, c) -> c) shc) + (compute $ sortBy getOrd (map (\(s, h, _) -> (s, h)) shc))
    where
        getOrd (sa, ha) (sb, hb) = if (sa * hb < sb * ha) then GT else LT

compute :: [(Int64, Int64)] -> Int64
compute shs =
    sum $ map (\((s, h'), h) -> s*(h-h')) $ zip shs hs
    where
        hs = scanr accumr 0 (map snd shs)
        accumr s c= s + c

countSHC :: String -> (Int64, Int64, Int64)
countSHC str =
    let ss = scanl (count 's') 0 str in
    let hs = scanr (flip $ count 'h') 0 str in
    (last ss, head hs, sum $ map (\(c, n) -> if c == 's' then n else 0) $ zip str hs)
    where
        count c n ch = n + (if c == ch then 1 else 0)

import Data.List
import Control.Monad

main = do
    n <- getLine >>= return . read
    shc <- replicateM n getLine >>= return . (map countSHC)
    print $ (sum $ map (\(_, _, c) -> c) shc) + (compute $ sortBy getOrd (map (\(s, h, _) -> (s, h)) shc))
    where
        getOrd (sa, ha) (sb, hb) = if (sa * hb < sb * ha) then GT else LT

compute :: [(Integer, Integer)] -> Integer
compute shs =
    sum $ map (\((s, h'), h) -> s*(h-h')) $ zip shs hs
    where
        hs :: [Integer]
        hs = scanr accumr 0 (map snd shs)
        accumr :: Integer -> Integer -> Integer
        accumr s c= s + c

countSHC :: String -> (Integer, Integer, Integer)
countSHC str =
    let ss = scanl (count 's') 0 str in
    let hs = scanr (flip $ count 'h') 0 str in
    (last ss, head hs, sum $ map (\(c, n) -> if c == 's' then n else 0) $ zip str hs)
    where
        count :: Char -> Integer -> Char -> Integer
        count c n ch = n + (if c == ch then 1 else 0)

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

countChar :: String -> Char -> Int64
countChar str c = foldl' (\acc cur -> if cur == c then acc + 1 else acc) 0 str

getSHRatio :: String -> Rational
getSHRatio str = (toRational $ countChar str 's') / (toRational $ countChar str 'h')

getHCount :: String -> [Int64]
getHCount [] = [0]
getHCount (x:xs)
    | x == 's' = f : res
    | otherwise = (f + 1) : res
    where res = getHCount xs
          f = head res

solve :: String -> [Int64] -> Int64
solve _ [] = 0
solve (x:xs) (h:hh)
    | x == 's' = h + rest
    | otherwise = rest
    where rest = solve xs hh

main :: IO ()
main = do
    n <- (read :: String -> Int64) <$> getLine
    lst <- mapM (\_ -> getLine) [1..n]
    let onlyS = join $ [x | x <- lst, not $ 'h' `elem` x]
        onlyH = join $ [x | x <- lst, not $ 's' `elem` x]
        both = [x | x <- lst, 'h' `elem` x && 's' `elem` x]
        bothWithCount = reverse . sort $ [(getSHRatio x, x) | x <- both]
        best = onlyS ++  (join $ map (\t -> snd t) bothWithCount) ++ onlyH
        hCount = tail $ getHCount best
        res = solve best hCount
    -- putStrLn . show $ best
    -- putStrLn . show $ hCount
    putStrLn . show $ res

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

transf :: String -> (Int64, Int64, String)
transf s = (x, y, s)
    where x = fromIntegral . length $ elemIndices 's' s
          y = (fromIntegral . length $ s) - x

compAns :: Int64 -> String -> Int64
compAns _ "" = 0
compAns st ('s':rest) = compAns (st + 1) rest
compAns st ('h':rest) = st + compAns st rest

main = do
    n <- readLn
    l <- replicateM n $ fmap transf getLine
    let sl = sortBy (\(a, b, _) (x, y, _) -> compare (b*x) (a*y)) l
    print . compAns 0 . join . map (\(_,_,x) -> x) $ sl

import Data.List
import Control.Monad

main = do
    n <- getLine >>= return . read
    shc <- replicateM n getLine >>= return . (map countSHC)
    print $ (sum $ map (\(_, _, c) -> c) shc) + (compute $ sortBy getOrd (map (\(s, h, _) -> (s, h)) shc))
    where
        getOrd (sa, ha) (sb, hb) = if (sa * hb < sb * ha) then GT else LT

compute :: [(Int, Int)] -> Int
compute shs =
    sum $ map (\((s, h'), h) -> s*(h-h')) $ zip shs hs
    where
        hs :: [Int]
        hs = scanr accumr 0 (map snd shs)
        accumr :: Int -> Int -> Int
        accumr s c= s + c

countSHC :: String -> (Int, Int, Int)
countSHC str =
    let ss = scanl (count 's') 0 str in
    let hs = scanr (flip $ count 'h') 0 str in
    (last ss, head hs, sum $ map (\(c, n) -> if c == 's' then n else 0) $ zip str hs)
    where
        count :: Char -> Int -> Char -> Int
        count c n ch = n + (if c == ch then 1 else 0)

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

countChar :: String -> Char -> Int
countChar str c = foldl' (\acc cur -> if cur == c then acc + 1 else acc) 0 str

getSHRatio :: String -> Rational
getSHRatio str = (toRational $ countChar str 's') / (toRational $ countChar str 'h')

getHCount :: String -> [Int]
getHCount [] = [0]
getHCount (x:xs)
    | x == 's' = f : res
    | otherwise = (f + 1) : res
    where res = getHCount xs
          f = head res

solve :: String -> [Int] -> Int
solve _ [] = 0
solve (x:xs) (h:hh)
    | x == 's' = h + rest
    | otherwise = rest
    where rest = solve xs hh

main :: IO ()
main = do
    n <- (read :: String -> Int) <$> getLine
    lst <- mapM (\_ -> getLine) [1..n]
    let onlyS = join $ [x | x <- lst, not $ 'h' `elem` x]
        onlyH = join $ [x | x <- lst, not $ 's' `elem` x]
        both = [x | x <- lst, 'h' `elem` x && 's' `elem` x]
        bothWithCount = reverse . sort $ [(getSHRatio x, x) | x <- both]
        best = onlyS ++  (join $ map (\t -> snd t) bothWithCount) ++ onlyH
        hCount = tail $ getHCount best
        res = solve best hCount
    -- putStrLn . show $ best
    -- putStrLn . show $ hCount
    putStrLn . show $ res

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

transf :: String -> (Int, Int, String)
transf s = (x, y, s)
    where x = length $ elemIndices 's' s
          y = length s - x

compAns :: Int64 -> String -> Int64
compAns _ "" = 0
compAns st ('s':rest) = compAns (st + 1) rest
compAns st ('h':rest) = st + compAns st rest

main = do
    n <- readLn
    l <- replicateM n $ fmap transf getLine
    let sl = sortBy (\(a, b, _) (x, y, _) -> compare (b*x) (a*y)) l
    print . compAns 0 . join . map (\(_,_,x) -> x) $ sl


AquaMoon has $$$n$$$ friends. They stand in a row from left to right, and the $$$i$$$-th friend from the left wears a T-shirt with a number $$$a_i$$$ written on it. Each friend has a direction (left or right). In the beginning, the direction of each friend is right.AquaMoon can make some operations on friends. On each operation, AquaMoon can choose two adjacent friends and swap their positions. After each operation, the direction of both chosen friends will also be flipped: left to right and vice versa.AquaMoon hopes that after some operations, the numbers written on the T-shirt of $$$n$$$ friends in the row, read from left to right, become non-decreasing. Also she wants, that all friends will have a direction of right at the end. Please find if it is possible.

The input consists of multiple test cases. The first line contains a single integer $$$t$$$ ($$$1 \leq t \leq 50$$$) — the number of test cases. The first line of each test case contains a single integer $$$n$$$ ($$$1 \leq n \leq 10^5$$$) — the number of Aquamoon's friends. The second line contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \leq a_i \leq 10^5$$$) — the numbers, written on the T-shirts. It is guaranteed that the sum of $$$n$$$ for all test cases does not exceed $$$10^5$$$.

For each test case, if there exists a possible sequence of operations, print "YES" (without quotes); otherwise, print "NO" (without quotes). You can print each letter in any case (upper or lower).

NoteThe possible list of operations in the first test case:  Swap $$$a_1$$$ and $$$a_2$$$. The resulting sequence is $$$3, 4, 2, 5$$$. The directions are: left, left, right, right.  Swap $$$a_2$$$ and $$$a_3$$$. The resulting sequence is $$$3, 2, 4, 5$$$. The directions are: left, left, right, right.  Swap $$$a_1$$$ and $$$a_2$$$. The resulting sequence is $$$2, 3, 4, 5$$$. The directions are: right, right, right, right.

{-# OPTIONS_GHC -O2 #-}

import Control.Monad
import Prelude as P

import Data.Word (Word8)
import Data.Int (Int64)
import qualified Data.Bits as Bits
import qualified Data.Char as Char

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

import qualified Data.ByteString as B
import qualified System.IO as Io
--import Data.IntSet

solve :: IO ()
solve = do
  n <- readLn :: IO Int
  sa <- getLine
  let a = map read $ words sa :: [Int]
      a_odd = oddelems a
      b_odd = oddelems $ sort a
      good = (sort a_odd == reverse b_odd)
    in putStrLn (if good then "YES" else "NO")
    where oddelems xs = foldl (\acc (i, x) -> if odd i then x : acc else acc) [] (zip [0..] xs)

main = do
  t <- readLn :: IO Int
  replicateM_ t solve

import Data.List as L

mergeLists :: [Int] -> [Int] -> [Int]
mergeLists [] [] = []
mergeLists x [] = x
mergeLists [] y = y
mergeLists (x:xs) (y:ys) = x:y:(mergeLists xs ys)

isSorted :: [Int] -> Bool
isSorted [] = True
isSorted [x] = True
isSorted (x:y:xs) = x <= y && isSorted (y:xs)

splitList :: [Int] -> ([Int], [Int])
splitList [] = ([], [])
splitList [x] = ([x], [])
splitList (x:y:xs) = (x:axs, y:bxs)
    where (axs, bxs) = splitList xs

solve :: Int -> IO ()
solve _ = do
    n <- (read :: String -> Int) <$> getLine
    -- putStrLn . show $ n
    lst <- map (\x -> (read :: String -> Int) x) . words <$> getLine
    -- putStrLn . show $ lst
    let (e, o) = splitList lst
        se = L.sort e
        so = L.sort o
        merged = mergeLists se so
        res = if isSorted merged then "Yes" else "No"
    putStrLn res

solveTest :: [Int] -> IO ()
solveTest [] = return ()
solveTest (x:xs) = do
    solve x
    solveTest xs

main :: IO ()
main = do
    t <- (read :: String -> Int) <$> getLine
    -- putStrLn . show $ t
    solveTest [1..t]

import Control.Monad
import Data.List
readInts = fmap (map read.words) getLine :: IO [Int]

solve [] _ = True
solve _ [] = True
solve (e:es) (o:os)
                | o >= e = solve (o:os) es
                | otherwise = False

printResult = do
    n <- readLn :: IO Int
    xs <- readInts
    let z = zip xs [0..]
        e = [a|(a,b)<-z,even b]
        o = [a|(a,b)<-z,odd b]
    putStrLn $ if solve (sort e) (sort o) then "YES" else "NO"

main = do
    t <- readLn :: IO Int
    replicateM_ t printResult

{-# 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.IO.Safe         as IOA
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, for)
import           System.IO                  (IOMode (ReadMode, WriteMode),
                                             hFlush, openFile, stdin, stdout)
import           Text.Printf                (printf)

import           Debug.Trace                (trace, traceM, traceShowM)
import           GHC.IO.Handle              (hDuplicateTo)

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 -> [Int] -> Bool
solve n as =
        all (all (\(k, v) -> v == 0) . IM.toList) cnts
    where
        sortAs :: [Int]
        sortAs = sort as

        md :: Int
        md = 2

        execCnts :: Int -> [Int] -> [IM.IntMap Int] -> [IM.IntMap Int]
        execCnts diff arr prevCnts =
                flip map (zip [0 ..] prevCnts) $ uncurry alterCnts
            where
                alterCnts :: Int -> IM.IntMap Int -> IM.IntMap Int
                alterCnts c mp =
                    foldl (\mp (i, e) -> if i `mod` md == c then IM.insertWith (+) e diff mp else mp) mp $
                        zip [0 ..] arr

        cnts :: [IM.IntMap Int]
        cnts =
            execCnts (-1) as $
            execCnts 1 sortAs $
            replicate md IM.empty

main :: IO ()
main = do
    tests <- B8.getLine <&> readIntB8
    replicateM_ tests $ do
        n <- B8.getLine <&> readIntB8
        as <- B8.getLine <&> map readIntB8 . B8.words

        let answer = solve n as

        putStrLn $ if answer then "YES" else "NO"

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 qualified Data.Map.Strict as M
import Data.Bool

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

data OddEven = Odd | Even deriving (Show, Eq, Ord, Enum, Bounded)

summarize :: [Int] -> M.Map (Int, OddEven) Int
summarize xs =
  let ks = zip xs $ fmap (bool Odd Even . even) [1..]
  in M.fromListWith (+) $ zip ks $ repeat 1

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    xs <- getInts n
    let ys = sort xs
    pure $ (<>char7 '\n') $! bool (string7 "NO") (string7 "YES") $ (summarize xs) == (summarize ys)

type SP = State [P.ByteString]

readInt :: P.ByteString -> Int
readInt = fst . fromJust . P.readInt

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

getInts :: Int -> SP [Int]
getInts k = map 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

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

interleave :: [a] -> [a] -> [a]
interleave (a:as) (b:bs) = a:b:interleave as bs
interleave a b = a ++ b

uninterleave :: [a] -> ([a], [a])
uninterleave (a1:a2:as) = let (x, y) = uninterleave as in (a1:x, a2:y)
uninterleave [a] = ([a], [])
uninterleave [] = ([], [])

both :: (a -> b) -> (a, a) -> (b, b)
both f (x, y) = (f x, f y)

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

isSorted :: Ord a => [a] -> Bool
isSorted [] = True
isSorted [a] = True
isSorted (a1:a2:as) = (a1 <= a2) && (isSorted (a2:as))

doit :: [Int] -> String
doit = toAnswer . isSorted . uncurry interleave . both sort . uninterleave

main :: IO ()
main = do
    t <- readLn
    replicateM_ t $ do
        getLine
        l <- fmap (map read . words) getLine
        putStrLn $ doit l

import Control.Arrow ((>>>))
import Data.Bool (bool)
import Data.List (group, groupBy, sort)

chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf k xs = let (hs, ts) = splitAt k xs in hs : chunksOf k ts

main :: IO ()
main =
  interact $
    lines >>> drop 1 >>> chunksOf 2
      >>> map (last >>> words >>> map read >>> solve >>> bool "No" "Yes")
      >>> unlines

solve :: [Int] -> Bool
solve =
  sorted
    . interleave
    . map (map snd)
    . groupBy (equating fst)
    . sort
    . zip ((`mod` 2) <$> [0 ..])

equating :: Eq a => (b -> a) -> b -> b -> Bool
equating f x y = f x == f y

sorted :: (Ord a) => [a] -> Bool
sorted xs = and $ zipWith (<=) xs (tail xs)

interleave :: [[a]] -> [a]
interleave [] = []
interleave xs = let xs' = filter (not . null) xs in map head xs' ++ interleave (map tail xs')

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Builder as B
import System.IO

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Data.List
import Data.Semigroup

evens :: [t] -> [t]
evens (p:q:rs) = p : evens rs
evens x = x

interleave :: [t] -> [t] -> [t]
interleave [] _ = []
interleave (x:xs) ys = x : interleave ys xs

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [t] <- readInts
  replicateM_ t $ do
    [n] <- readInts
    a <- readInts
    let
      a1 = sort $ evens a
      a2 = sort $ evens $ tail a
      opt = interleave a1 a2
      ans = and $ zipWith (<=) opt (tail opt)
    lift $ B.hPutBuilder stdout $ if  ans
      then  B.string7 "YES\n"
      else  B.string7 "NO\n"

type SIO = StateT P.ByteString IO

readLine :: SIO P.ByteString
readLine = do
  (out, next) <- P.break (<= '\r') <$> get
  put $ P.dropWhile (<= '\r') next
  pure out

readInts :: SIO [Int]
readInts = do
  currLine <- readLine
  pure [x | Just (x, _) <- P.readInt <$> P.words currLine]

putInts :: [Int] -> SIO ()
putInts li = let
  outBuilder = foldr (<>) (B.char7 '\n')
    $ intersperse (B.char7 ' ') (map B.intDec li)
  in  lift $ B.hPutBuilder stdout outBuilder


You are given an array consisting of n non-negative integers a1, a2, ..., an.You are going to destroy integers in the array one by one. Thus, you are given the permutation of integers from 1 to n defining the order elements of the array are destroyed.After each element is destroyed you have to find out the segment of the array, such that it contains no destroyed elements and the sum of its elements is maximum possible. The sum of elements in the empty segment is considered to be 0.

The first line of the input contains a single integer n (1 ≤ n ≤ 100 000) — the length of the array. The second line contains n integers a1, a2, ..., an (0 ≤ ai ≤ 109).  The third line contains a permutation of integers from 1 to n — the order used to destroy elements.

Print n lines. The i-th line should contain a single integer — the maximum possible sum of elements on the segment containing no destroyed elements, after first i operations are performed.

NoteConsider the first sample:   Third element is destroyed. Array is now 1 3  *  5. Segment with maximum sum 5 consists of one integer 5.  Fourth element is destroyed. Array is now 1 3  *   * . Segment with maximum sum 4 consists of two integers 1 3.  First element is destroyed. Array is now  *  3  *   * . Segment with maximum sum 3 consists of one integer 3.  Last element is destroyed. At this moment there are no valid nonempty segments left in this array, so the answer is equal to 0.

import qualified Data.ByteString.Char8 as B
import Control.Monad
import Data.Array
import Data.Maybe
import Data.Set hiding (map, foldl)
import qualified Data.Map as M

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

inf = round 1e18

add k m = case M.lookup k m of
            Just _ -> M.update (return . succ) k m
            _ -> M.insert k 1 m

remove :: Integer -> M.Map Integer Integer -> M.Map Integer Integer
remove k m = case M.lookup k m of
            Just x -> if x == 1 then M.delete k m else M.update (return . pred) k m
            _ -> error "Key doesn't exist"

main :: IO ()
main = do
    n <- readLn
    a <- readIntList
    b <- readIntList
    let pre = listArray (0,n+1) ((scanl (+) 0 a)++[0])
        for :: Set (Integer,Integer) -> M.Map Integer Integer -> [Integer] -> IO()
        for st mp (i:is) = do
            let (a,b) = fromJust $ lookupLE (i,inf) st
                st' = delete (a,b) st
                mp' = remove (pre!b - pre!(a-1)) mp
                (nst,nmp) = foldl fn (st',mp') [(a,i-1),(i+1,b)]
                fn (st,mp) (x,y)
                 |y >= x = (insert (x,y) st, add (pre!y - pre!(x-1)) mp)
                 |otherwise = (st,mp)
            -- print (st,mp)
            if M.null nmp
                then print 0
                else do
                    print . fst . M.findMax $ nmp
                    for nst nmp is
    for (fromList [(1,n)]) (M.fromList [(pre!n,1)]) b

{-
TODO:
1. Read from IO
2. Convert [Int] to mutable [(0 | Sum, rootId | 0, 0 | length)]
3. Write fold fn which returns current maximum sum.
-}
module Main where
import Data.Array
import Control.Monad
import Control.Monad.ST.Safe
import Data.Array.ST.Safe
-- import Debug.Trace
import Data.STRef (newSTRef, modifySTRef, readSTRef)
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromJust)

type Set = ((Integer, Integer), Integer)

-- values as first argument
-- sequence to remove as second
getSum :: [Integer] -> [Integer] -> [Integer]
getSum ys xs =
  let els = listArray (0, pred $ toInteger $ length ys) $ zip (zip [1, 1..] [-1, -1..]) ys :: Array Integer Set
  in run (reverse xs) els

run :: [Integer] -> Array Integer Set -> [Integer]
run xs els' = runST $ do
  els <- thaw els'
  curMaxSum <- newSTRef 0
  res' <- forM xs $ \i' -> do
    let i = pred i'
        l = toInteger $ length xs
    visit i els
    union i (pred i) els $ pred l
    union i (succ i) els $ pred l
    root <- findRoot i els
    ((_,_), sumI) <- readArray els root
    modifySTRef curMaxSum (\x -> max x sumI)
    newMax <- readSTRef curMaxSum
    -- trace (show $ newMax) $ return ()
    readSTRef curMaxSum
  return res'

visit :: Integer -> STArray s Integer Set -> ST s ()
visit i els = do
  ((l, _), y) <- readArray els i
  writeArray els i $ ((l, i), y)

findRoot :: Integer -> STArray s Integer Set -> ST s Integer
findRoot i els = do
  ((_, rootId), _) <- readArray els i
  if (rootId == i || rootId == -1) then return rootId
  else findRoot rootId els

union :: Integer -> Integer -> STArray s Integer Set -> Integer -> ST s ()
union i j els maxJ
  | j < 0 || j > maxJ = return ()
  | otherwise = do
    rootI' <- findRoot i els
    rootJ' <- findRoot j els
    -- one of the elements was not visited yet. Nothing to union
    if (rootI' == -1 || rootJ' == -1) then return ()
    else do
      ((lI, rootI), sumI) <- readArray els rootI'
      ((lJ, rootJ), sumJ) <- readArray els rootJ'
      writeArray els rootI ((lI + lJ, rootI), sumI + sumJ)
      writeArray els rootJ ((0, rootI), 0)

readInt = fromIntegral . fst . fromJust . B.readInteger
readLine =
  B.getLine >>= return . map readInt . B.words

main = do
  [_] <- readLine
  array <- readLine
  order <- readLine
  mapM_ print $ tail $ reverse $ (:) 0 $ getSum array order

-- import qualified Data.IntMap as M
import qualified Data.Map.Strict as M
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromJust, fromMaybe)
import Data.List (scanr)

readInt = fromIntegral . fst . fromJust . B.readInteger

readLine =
  B.getLine >>= return . map readInt . B.words

solve a i (m, curmax) =
  let
    n = a M.! i
    left = M.lookup (i-1) m
    right = M.lookup (i+1) m
    newGroup =
      ( ( fromMaybe i . fmap (fst . fst) $ left
        , fromMaybe i . fmap (snd . fst) $ right
        )
      , n
          + (fromMaybe 0 . fmap snd $ left)
          + (fromMaybe 0 . fmap snd $ right)
      )
  in
    ( M.insert (fst . fst $ newGroup) newGroup
      . M.insert (snd . fst $ newGroup) newGroup
      $ m
    , max curmax $ snd newGroup
    )

main = do
  [n] <- readLine
  array <- readLine
  order <- readLine
  B.putStrLn . B.pack . unlines . map (show . snd) . drop 1 $ scanr (solve $ M.fromAscList (zip [1..] array)) (M.empty, 0) order

{-# OPTIONS_GHC -O2 #-}
{-# LANGUAGE BangPatterns #-}
import           Control.Applicative
import           Control.Monad
import           Data.Array
import qualified Data.ByteString.Char8 as B
import           Data.Int
import qualified Data.IntMap           as IM

main :: IO ()
main = do
  n <- readLn :: IO Int
  xs <- map (fromIntegral.readInt).B.words <$> B.getLine
  ys <- map (subtract 1.readInt).B.words <$> B.getLine
  putStr.unlines.map show $ solve n xs ys

solve :: Int -> [Int64] -> [Int] -> [Int64]
solve n xs ys = go [] 0 IM.empty IM.empty $ reverse ys
  where
    arr = listArray(0, n-1) xs
    go res acc ls rs (k:ks) = go (acc:res) res' ls' rs' ks
      where
        !res' = max acc s
        !v = arr ! k
        !s = sl + v + sr
        (l, sl) = case IM.lookup (k-1) rs of
            Just (lk, s) -> (lk, s)
            Nothing -> (k, 0)
        (r, sr) = case IM.lookup (k+1) ls of
            Just (rk, s) -> (rk, s)
            Nothing -> (k, 0)
        rs' = IM.insert r (l, s) $ IM.delete (k-1) rs
        ls' = IM.insert l (r, s) $ IM.delete (k+1) ls
    go res _ _ _ [] = res

readInt :: B.ByteString -> Int
readInt bs=case B.readInt bs of{Just(n,_)->n;_->error$"readInt error : bs = "++show bs;}

import qualified Data.ByteString.Char8 as B
import Control.Monad
import Data.Array
import Data.Maybe
import Data.Set hiding (map, foldl)

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

inf = round 2e9

main :: IO ()
main = do
    n <- readLn
    a <- readIntList
    b <- readIntList
    let pre = listArray (0,n+1) ((scanl (+) 0 a)++[0])
        for :: Set (Integer,Integer) -> Set Integer -> [Integer] -> IO ()
        for st1 st2 (i:is) = do
            let (a,b) = fromJust $ lookupLE (i,inf) st1 :: (Integer,Integer)
                st1' = delete (a,b) st1
                st2' = delete (pre!b - pre!(a-1)) st2
                (nst1,nst2) = foldl fn (st1',st2') [(a,i-1),(i+1,b)]
                fn (st1,st2) (x,y)
                 |pre!y - pre!(x-1) > 0 = (insert (x,y) st1, insert (pre!y - pre!(x-1)) st2)
                 |otherwise = (st1,st2)
            case maxView nst2 of
                Just x -> do
                    print . fst $ x
                    for nst1 nst2 is
                _ -> print 0
    for (fromList [(1,n)]) (fromList [pre!n]) b

module Main where
import Data.Array
import Control.Monad
import Control.Monad.ST.Safe
import Data.Array.ST.Safe
-- import Debug.Trace
import Data.STRef (newSTRef, modifySTRef, readSTRef)
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromJust)

type Set = ((Int, Int), Int)

-- values as first argument
-- sequence to remove as second
getSum :: [Int] -> [Int] -> [Int]
getSum ys xs =
  let els = listArray (0, pred $ length ys) $ zip (zip [1, 1..] [-1, -1..]) ys :: Array Int Set
  in run (reverse xs) els

run :: [Int] -> Array Int Set -> [Int]
run xs els' = runST $ do
  els <- thaw els'
  curMaxSum <- newSTRef 0
  res' <- forM xs $ \i' -> do
    let i = pred i'
        l = length xs
    visit i els
    union i (pred i) els $ pred l
    union i (succ i) els $ pred l
    root <- findRoot i els
    ((_,_), sumI) <- readArray els root
    modifySTRef curMaxSum (\x -> max x sumI)
    newMax <- readSTRef curMaxSum
    -- trace (show $ newMax) $ return ()
    readSTRef curMaxSum
  return res'

visit :: Int -> STArray s Int Set -> ST s ()
visit i els = do
  ((l, _), y) <- readArray els i
  writeArray els i $ ((l, i), y)

findRoot :: Int -> STArray s Int Set -> ST s Int
findRoot i els = do
  ((_, rootId), _) <- readArray els i
  if (rootId == i || rootId == -1) then return rootId
  else findRoot rootId els

union :: Int -> Int -> STArray s Int Set -> Int -> ST s ()
union i j els maxJ
  | j < 0 || j > maxJ = return ()
  | otherwise = do
    rootI' <- findRoot i els
    rootJ' <- findRoot j els
    -- one of the elements was not visited yet. Nothing to union
    if (rootI' == -1 || rootJ' == -1) then return ()
    else do
      ((lI, rootI), sumI) <- readArray els rootI'
      ((lJ, rootJ), sumJ) <- readArray els rootJ'
      writeArray els rootI ((lI + lJ, rootI), sumI + sumJ)
      writeArray els rootJ ((0, rootI), 0)

readInt = fromIntegral . fst . fromJust . B.readInteger
readLine =
  B.getLine >>= return . map readInt . B.words

main = do
  [_] <- readLine
  array <- readLine
  order <- readLine
  mapM_ print $ tail $ reverse $ (:) 0 $ getSum array order

import qualified Data.IntMap as M
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromJust, fromMaybe)
import Data.List (scanr)

readInt = fromIntegral . fst . fromJust . B.readInteger

readLine =
  B.getLine >>= return . map readInt . B.words

solve :: M.IntMap Int -> Int -> (M.IntMap ((Int, Int), Int), Int) -> (M.IntMap ((Int, Int), Int), Int)
solve a i (m, curmax) =
  let
    n = a M.! i
    left = M.lookup (i-1) m
    right = M.lookup (i+1) m
    newGroup =
      ( ( fromMaybe i . fmap (fst . fst) $ left
        , fromMaybe i . fmap (snd . fst) $ right
        )
      , n
          + (fromMaybe 0 . fmap snd $ left)
          + (fromMaybe 0 . fmap snd $ right)
      )
  in
    ( M.insert (fst . fst $ newGroup) newGroup
      . M.insert (snd . fst $ newGroup) newGroup
      $ m
    , max curmax $ snd newGroup
    )

main = do
  [n] <- readLine
  array <- readLine
  order <- readLine
  B.putStrLn . B.pack . unlines . map (show . snd) . drop 1 $ scanr (solve $ M.fromAscList (zip [1..] array)) (M.empty, 0) order


Natasha is going to fly on a rocket to Mars and return to Earth. Also, on the way to Mars, she will land on $$$n - 2$$$ intermediate planets. Formally: we number all the planets from $$$1$$$ to $$$n$$$. $$$1$$$ is Earth, $$$n$$$ is Mars. Natasha will make exactly $$$n$$$ flights: $$$1 \to 2 \to \ldots n \to 1$$$.Flight from $$$x$$$ to $$$y$$$ consists of two phases: take-off from planet $$$x$$$ and landing to planet $$$y$$$. This way, the overall itinerary of the trip will be: the $$$1$$$-st planet $$$\to$$$ take-off from the $$$1$$$-st planet $$$\to$$$ landing to the $$$2$$$-nd planet $$$\to$$$ $$$2$$$-nd planet $$$\to$$$ take-off from the $$$2$$$-nd planet $$$\to$$$ $$$\ldots$$$ $$$\to$$$ landing to the $$$n$$$-th planet $$$\to$$$ the $$$n$$$-th planet $$$\to$$$ take-off from the $$$n$$$-th planet $$$\to$$$ landing to the $$$1$$$-st planet $$$\to$$$ the $$$1$$$-st planet.The mass of the rocket together with all the useful cargo (but without fuel) is $$$m$$$ tons. However, Natasha does not know how much fuel to load into the rocket. Unfortunately, fuel can only be loaded on Earth, so if the rocket runs out of fuel on some other planet, Natasha will not be able to return home. Fuel is needed to take-off from each planet and to land to each planet. It is known that $$$1$$$ ton of fuel can lift off $$$a_i$$$ tons of rocket from the $$$i$$$-th planet or to land $$$b_i$$$ tons of rocket onto the $$$i$$$-th planet. For example, if the weight of rocket is $$$9$$$ tons, weight of fuel is $$$3$$$ tons and take-off coefficient is $$$8$$$ ($$$a_i = 8$$$), then $$$1.5$$$ tons of fuel will be burnt (since $$$1.5 \cdot 8 = 9 + 3$$$). The new weight of fuel after take-off will be $$$1.5$$$ tons. Please note, that it is allowed to burn non-integral amount of fuel during take-off or landing, and the amount of initial fuel can be non-integral as well.Help Natasha to calculate the minimum mass of fuel to load into the rocket. Note, that the rocket must spend fuel to carry both useful cargo and the fuel itself. However, it doesn't need to carry the fuel which has already been burnt. Assume, that the rocket takes off and lands instantly.

The first line contains a single integer $$$n$$$ ($$$2 \le n \le 1000$$$) — number of planets. The second line contains the only integer $$$m$$$ ($$$1 \le m \le 1000$$$) — weight of the payload. The third line contains $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$ ($$$1 \le a_i \le 1000$$$), where $$$a_i$$$ is the number of tons, which can be lifted off by one ton of fuel. The fourth line contains $$$n$$$ integers $$$b_1, b_2, \ldots, b_n$$$ ($$$1 \le b_i \le 1000$$$), where $$$b_i$$$ is the number of tons, which can be landed by one ton of fuel.  It is guaranteed, that if Natasha can make a flight, then it takes no more than $$$10^9$$$ tons of fuel.

If Natasha can fly to Mars through $$$(n - 2)$$$ planets and return to Earth, print the minimum mass of fuel (in tons) that Natasha should take. Otherwise, print a single number $$$-1$$$. It is guaranteed, that if Natasha can make a flight, then it takes no more than $$$10^9$$$ tons of fuel. The answer will be considered correct if its absolute or relative error doesn't exceed $$$10^{-6}$$$. Formally, let your answer be $$$p$$$, and the jury's answer be $$$q$$$. Your answer is considered correct if $$$\frac{|p - q|}{\max{(1, |q|)}} \le 10^{-6}$$$.

NoteLet's consider the first example.Initially, the mass of a rocket with fuel is $$$22$$$ tons. At take-off from Earth one ton of fuel can lift off $$$11$$$ tons of cargo, so to lift off $$$22$$$ tons you need to burn $$$2$$$ tons of fuel. Remaining weight of the rocket with fuel is $$$20$$$ tons. During landing on Mars, one ton of fuel can land $$$5$$$ tons of cargo, so for landing $$$20$$$ tons you will need to burn $$$4$$$ tons of fuel. There will be $$$16$$$ tons of the rocket with fuel remaining. While taking off from Mars, one ton of fuel can raise $$$8$$$ tons of cargo, so to lift off $$$16$$$ tons you will need to burn $$$2$$$ tons of fuel. There will be $$$14$$$ tons of rocket with fuel after that. During landing on Earth, one ton of fuel can land $$$7$$$ tons of cargo, so for landing $$$14$$$ tons you will need to burn $$$2$$$ tons of fuel. Remaining weight is $$$12$$$ tons, that is, a rocket without any fuel.In the second case, the rocket will not be able even to take off from Earth.

import Data.List

main = do
  getLine
  m <- readLn :: IO Double
  a <- fmap (map read . words) getLine :: IO [Double]
  b <- fmap (map read . words) getLine :: IO [Double]
  let c = concat . zipWith (\a b -> [b, a]) (reverse a) $ head b : (reverse . tail $ b)
  let tot = foldl' (\x a -> x + x / (a - 1)) m c
  print $ if any (== 1) $ a ++ b then -1 else tot - m

main :: IO ()
main = do
    input <- sequence [getLine, getLine, getLine, getLine]
    let count = read (head input) :: Int
    let mass = read (input !! 1) :: Int
    let ka = map (read::String->Int) (words(input !! 2))
    let kb = map (read::String->Int) (words(input !! 3))
    print (calculate count mass ka kb)

calculate :: Int -> Int -> [Int] -> [Int] -> Double
calculate _ mass ka kb = result
    where
        result = if noValue
            then -1.0
            else fly (fromIntegral mass) 0.0 k
        k = prepare ka kb
        noValue = 1 `elem` k

prepare :: [Int] -> [Int] -> [Int]
prepare ka kb = reverseList (merge ka (tail kb ++ [head kb]))

fly :: Double -> Double -> [Int] -> Double
fly mass fuel (k:ks) = fly mass (fuel + fuelIncrement (mass + fuel) k) ks
fly mass fuel [] = fuel

fuelIncrement :: Double -> Int -> Double
fuelIncrement mass k = mass / fromIntegral (k - 1)

merge :: [a] -> [a] -> [a]
merge (x:xs) (y:ys) = x : y : merge xs ys
merge [] [] = []

reverseList :: [a] -> [a]
reverseList [] = []
reverseList (x:xs) = reverseList xs ++ [x]

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

import Data.Array
import Data.Char
import Data.Functor
import Data.List
import Data.Int
import qualified Data.Set as S
import qualified Data.ByteString.Char8 as B
import Control.Monad

if' :: Bool -> a -> a -> a
if' True  x _ = x
if' False _ y = y

getInts :: IO [Int]
getInts = unfoldr (B.readInt . B.dropWhile isSpace) <$> B.getLine

solve :: Double -> [Int] -> [Int] -> Double
solve m a b = if' (c > 0) (m / c - m) (-1)
	where c = product $ map ((\x -> 1 - 1/x) . fromIntegral) $ (a ++ b)

main :: IO ()
main = do
	[n] <- getInts
	[m] <- getInts
	a <- getInts
	b <- getInts
	print (solve (fromIntegral m) a b)

import Data.Ratio

main = do
    n <- fmap (read :: String -> Int) $ getLine
    m <- fmap (toRational . (read :: String -> Double)) $ getLine
    a <- fmap (map (toRational . (read :: String -> Double)) . words) $ getLine
    b <- fmap (map (toRational . (read :: String -> Double)) . words) $ getLine

    let d = product [1 - 1/x | x <- a] * product [1 - 1/x | x <- b]

    let answer = if d > 0 then show . fromRational $ m * (1 - d) / d
        else show (negate 1)

    putStrLn answer

toint s = (read s) :: Int

itod x = (fromIntegral x) :: Double

can::Double -> [Double] -> [Double] -> Double -> Bool
can m [] [] f = True
can m (a:as) (b:bs) f =
  let x = (m + f) / a in
  if f - x < 0 then
    False
  else
    let ff = f - x in
    let xx = (m+ff) / b in
    if ff-xx < 0 then
      False
    else
      can m as bs (ff-xx)

bs m a b s e i =
  if i == 70 then
    s
  else
    let mid = (s+e)/2 in
    if can m a b mid then
      bs m a b s mid (i+1)
    else
      bs m a b mid e (i+1)

solve::String -> String
solve sss =
    let (n:mm:ss) = Prelude.map toint $ words sss in
    let a = map itod $ take n ss in
    let bb = map itod $ take n $ drop n ss in
    let b = (tail bb) ++ [head bb] in
    let m = itod mm in
    if can m a b 1.1e9 then
      show (bs m a b 0.0 1.1e9 0) ++ "\n"
    else
      "-1\n"

main = interact solve

main = interact foo

foo :: String -> String
foo inp =
    let _:m:as:bs:_ = lines inp
        cargo = read m :: Double
        li:lifts = map read $ words as :: [Double]
        landings = map read $ words bs :: [Double]
        transits = zip (li: (reverse lifts)) (reverse landings)
        fuel = (flip (-) cargo) $ foldl (\c (lif, lan) -> transit c lif lan) cargo transits
    in if fuel == 1/0 then "-1" else show fuel

-- reversed
-- weight before -> takeoff -> landing -> weight after
transit :: Double -> Double -> Double -> Double
transit w a b =
    let w' = lift w a
    in lift w' b

-- weight before -> takeoff/lanfding -> weight after
lift :: Double -> Double -> Double
lift w a =
    let f = w / (a-1)
    in w + f

merge :: [a] -> [a] -> [a]
merge (a:as) (b:bs) = a : b : merge as bs
merge a [] = a
merge _ b = b

compute :: [Int] -> Double -> Double
compute (1:_) _ = -1
compute (c:cs) w = compute cs $ w * (fromIntegral c) / (fromIntegral c-1)
compute _ w = w

main = do
    getLine
    m <- fmap (fromIntegral . read) getLine
    a <- fmap (map read . words) getLine
    b1:bs <- fmap (map read . words) getLine
    let coeffs = b1 : reverse (merge a bs)
    let res = compute coeffs m
    if res < 0 then print (-1)
        else print $ res - m

merge :: [a] -> [a] -> [a]
merge (a:as) (b:bs) = a : b : merge as bs
merge a [] = a
merge _ b = b

compute :: [Int] -> Float -> Float
compute (1:_) _ = -1
compute (c:cs) w = compute cs $ w * (fromIntegral c) / (fromIntegral c-1)
compute _ w = w

main = do
    getLine
    m <- fmap (fromIntegral . read) getLine
    a <- fmap (map read . words) getLine
    b1:bs <- fmap (map read . words) getLine
    let coeffs = b1 : reverse (merge a bs)
    let res = compute coeffs m
    if res < 0 then print (-1)
        else print $ res - m