This is the easy version of the problem. The only difference between the two versions is the constraint on $$$n$$$. You can make hacks only if all versions of the problem are solved.A forest is an undirected graph without cycles (not necessarily connected).Mocha and Diana are friends in Zhijiang, both of them have a forest with nodes numbered from $$$1$$$ to $$$n$$$, and they would like to add edges to their forests such that:   After adding edges, both of their graphs are still forests.  They add the same edges. That is, if an edge $$$(u, v)$$$ is added to Mocha's forest, then an edge $$$(u, v)$$$ is added to Diana's forest, and vice versa. Mocha and Diana want to know the maximum number of edges they can add, and which edges to add.

The first line contains three integers $$$n$$$, $$$m_1$$$ and $$$m_2$$$ ($$$1 \le n \le 1000$$$, $$$0 \le m_1, m_2 < n$$$) — the number of nodes and the number of initial edges in Mocha's forest and Diana's forest. Each of the next $$$m_1$$$ lines contains two integers $$$u$$$ and $$$v$$$ ($$$1 \le u, v \le n$$$, $$$u \neq v$$$) — the edges in Mocha's forest. Each of the next $$$m_2$$$ lines contains two integers $$$u$$$ and $$$v$$$ ($$$1 \le u, v \le n$$$, $$$u \neq v$$$) — the edges in Diana's forest.

The first line contains only one integer $$$h$$$, the maximum number of edges Mocha and Diana can add (in each forest). Each of the next $$$h$$$ lines contains two integers $$$u$$$ and $$$v$$$ ($$$1 \le u, v \le n$$$, $$$u \neq v$$$) — the edge you add each time. If there are multiple correct answers, you can print any one of them.

NoteIn the first example, we cannot add any edge.In the second example, the initial forests are as follows.We can add an edge $$$(2, 4)$$$.

import Control.Monad
import Data.List
import Data.Maybe (fromJust)
import qualified Data.IntMap as IM

type Components = IM.IntMap Int

buildComponents' :: Components -> [(Int,Int)] -> Components
buildComponents' comp [] = comp
buildComponents' comp ((i,j):xs) =
  let (a,comp') = getClass i comp
      (b,comp'') = getClass j comp
  in
    buildComponents' (IM.insert a b comp'') xs

buildComponents :: Int -> [(Int,Int)] -> Components
buildComponents n pairs =
  buildComponents' (IM.fromList $ zip [1..n] [1..n]) pairs

readEdge :: Int -> IO (Int,Int)
readEdge i = do
  line <- getLine
  let [u,v] = map read $ words line
  return (u,v)

getClass :: Int -> Components -> (Int,Components)
getClass n comp =
  let a = fromJust $ IM.lookup n comp
  in
    if a == n then (a, comp)
    else
      let (class',comp') = getClass a comp in
        (class', IM.insert n class' comp')

newEdges :: Int -> Components -> Components -> [(Int,Int)]
newEdges n comp1 comp2 =
  let pairs = [(i,j) | i <- [1..n], j <- [i+1..n]]
      (r,_,_) = foldl (\(lst,comp1,comp2) (i,j) ->
              let (a1,comp1') = getClass i comp1
                  (b1,comp1'') = getClass j comp1'
                  (a2,comp2') = getClass i comp2
                  (b2,comp2'') = getClass j comp2'
              in
                if (a1 /= b1) && (a2 /= b2) then
                  (((i,j):lst),IM.insert a1 b1 comp1'',IM.insert a2 b2 comp2'')
                else
                  (lst,comp1'',comp2'')
           ) ([],comp1,comp2) pairs
  in r

main = do
  line <- getLine
  let [n,m1,m2] = map read $ words line :: [Int]
  g1 <- mapM readEdge [1..m1]
  g2 <- mapM readEdge [1..m2]
  let comp1 = buildComponents n g1
  let comp2 = buildComponents n g2
  let edges = newEdges n comp1 comp2
  print $ length edges
  forM_ edges $ \(i,j) -> do
    putStrLn ((show i) ++ " " ++ (show j))

import Control.Monad
import Data.List
import Data.Maybe (fromJust)
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS

type Graph = IM.IntMap [Int]
type Visit = (IS.IntSet,IS.IntSet)
type Components = IM.IntMap Int

buildGraph :: [(Int,Int)] -> Graph
buildGraph edges =
  let add = (\u lst ->
               case lst of
                 Just lst' -> Just (u:lst')
                 Nothing -> Just [u]
               )
  in
    foldl (\g (u,v) ->
             IM.alter (add u) v $ IM.alter (add v) u g
          ) IM.empty edges

dfs' :: Int -> Int -> Graph -> IS.IntSet -> IS.IntSet
dfs' parent cur gr visited =
  let vis = IS.insert cur visited in
    case IM.lookup cur gr of
      Just children ->
        foldl (\visited' child ->
                 if child == parent then visited'
                 else dfs' cur child gr visited'
              ) vis children
      Nothing -> vis

dfs :: Graph -> [IS.IntSet]
dfs graph =
  let visited = IS.empty
      conn = []
  in
    snd $ IM.foldlWithKey (\(vis',conn') k _ ->
                       if IS.member k vis' then (vis',conn')
                       else
                         let component = dfs' (-1) k graph IS.empty in
                           (IS.union vis' component,component:conn')
                    ) (visited,[]) graph

buildComponents' :: Components -> [(Int,Int)] -> Components
buildComponents' comp [] = comp
buildComponents' comp ((i,j):xs) =
  let (a,comp') = getClass i comp
      (b,comp'') = getClass j comp
  in
    buildComponents' (IM.insert a b comp'') xs

buildComponents :: Int -> [(Int,Int)] -> Components
buildComponents n pairs =
  buildComponents' (IM.fromList $ zip [1..n] [1..n]) pairs

enumComponents' :: Components -> [IS.IntSet] -> Components
enumComponents' m [] = m
enumComponents' m (x:xs) =
  let m' = snd $ IS.foldl (\(init,m') k ->
              let init1 = if init<0 then k else init in
                (init1,IM.insert k init1 m')
              ) ((-1),m) x
  in
    enumComponents' m' xs

enumComponents :: Int -> [IS.IntSet] -> Components
enumComponents n components =
  enumComponents' (IM.fromList $ zip [1..n] [1..n]) components

readEdge :: Int -> IO (Int,Int)
readEdge i = do
  line <- getLine
  let [u,v] = map read $ words line
  return (u,v)

getClass :: Int -> Components -> (Int,Components)
getClass n comp =
  let a = fromJust $ IM.lookup n comp
  in
    if a == n then (a, comp)
    else
      let (class',comp') = getClass a comp in
        (class', IM.insert n class' comp')

newEdges :: Int -> Components -> Components -> [(Int,Int)]
newEdges n comp1 comp2 =
  let pairs = [(i,j) | i <- [1..n], j <- [i+1..n]]
      (r,_,_) = foldl (\(lst,comp1,comp2) (i,j) ->
              let (a1,comp1') = getClass i comp1
                  (b1,comp1'') = getClass j comp1'
                  (a2,comp2') = getClass i comp2
                  (b2,comp2'') = getClass j comp2'
              in
                if (a1 /= b1) && (a2 /= b2) then
                  (((i,j):lst),IM.insert a1 b1 comp1'',IM.insert a2 b2 comp2'')
                else
                  (lst,comp1'',comp2'')
           ) ([],comp1,comp2) pairs
  in r

main = do
  line <- getLine
  let [n,m1,m2] = map read $ words line :: [Int]
  g1 <- mapM readEdge [1..m1]
  g2 <- mapM readEdge [1..m2]
  let comp1 = buildComponents n g1
  let comp2 = buildComponents n g2
  --let gr1 = buildGraph g1
  --let gr2 = buildGraph g2
  --let con1 = dfs gr1
  --let con2 = dfs gr2
  --let comp1 = enumComponents n con1
  --let comp2 = enumComponents n con2
  --putStrLn $ show gr1
  --putStrLn $ show gr2
  putStrLn $ show comp1
  putStrLn $ show comp2
  let edges = newEdges n comp1 comp2
  print $ length edges
  forM_ edges $ \(i,j) -> do
    putStrLn ((show i) ++ " " ++ (show j))

import Control.Monad
import Data.List
import Data.Maybe (fromJust)
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS

type Graph = IM.IntMap [Int]
type Visit = (IS.IntSet,IS.IntSet)
type Components = IM.IntMap Int

buildGraph :: [(Int,Int)] -> Graph
buildGraph edges =
  let add = (\u lst ->
               case lst of
                 Just lst' -> Just (u:lst')
                 Nothing -> Just [u]
               )
  in
    foldl (\g (u,v) ->
             IM.alter (add u) v $ IM.alter (add v) u g
          ) IM.empty edges

dfs' :: Int -> Int -> Graph -> IS.IntSet -> IS.IntSet
dfs' parent cur gr visited =
  let vis = IS.insert cur visited in
    case IM.lookup cur gr of
      Just children ->
        foldl (\visited' child ->
                 if child == parent then visited'
                 else dfs' cur child gr visited'
              ) vis children
      Nothing -> vis

dfs :: Graph -> [IS.IntSet]
dfs graph =
  let visited = IS.empty
      conn = []
  in
    snd $ IM.foldlWithKey (\(vis',conn') k _ ->
                       if IS.member k vis' then (vis',conn')
                       else
                         let component = dfs' (-1) k graph IS.empty in
                           (IS.union vis' component,component:conn')
                    ) (visited,[]) graph

enumComponents' :: Components -> [IS.IntSet] -> Components
enumComponents' m [] = m
enumComponents' m (x:xs) =
  let m' = snd $ IS.foldl (\(init,m') k ->
              let init1 = if init<0 then k else init in
                (init1,IM.insert k init1 m')
              ) ((-1),m) x
  in
    enumComponents' m' xs

enumComponents :: Int -> [IS.IntSet] -> Components
enumComponents n components =
  enumComponents' (IM.fromList $ zip [1..n] [1..n]) components

readEdge :: Int -> IO (Int,Int)
readEdge i = do
  line <- getLine
  let [u,v] = map read $ words line
  return (u,v)

getClass :: Int -> Components -> (Int,Components)
getClass n comp =
  let a = fromJust $ IM.lookup n comp
  in
    if a == n then (a, comp)
    else
      let (class',comp') = getClass a comp in
        (class', IM.insert n class' comp')

newEdges :: Int -> Components -> Components -> [(Int,Int)]
newEdges n comp1 comp2 =
  let pairs = [(i,j) | i <- [1..n], j <- [i+1..n]]
      (r,_,_) = foldl (\(lst,comp1,comp2) (i,j) ->
              let (a1,comp1') = getClass i comp1
                  (b1,comp1'') = getClass j comp1'
                  (a2,comp2') = getClass i comp2
                  (b2,comp2'') = getClass j comp2'
              in
                if (a1 /= b1) && (a2 /= b2) then
                  (((i,j):lst),IM.insert i j comp1'',IM.insert i j comp2'')
                else
                  (lst,comp1'',comp2'')
           ) ([],comp1,comp2) pairs
  in r

main = do
  line <- getLine
  let [n,m1,m2] = map read $ words line :: [Int]
  g1 <- mapM readEdge [1..m1]
  g2 <- mapM readEdge [1..m2]
  let gr1 = buildGraph g1
  let gr2 = buildGraph g2
  let con1 = dfs gr1
  let con2 = dfs gr2
  let comp1 = enumComponents n con1
  let comp2 = enumComponents n con2
  --putStrLn $ show gr1
  --putStrLn $ show gr2
  --putStrLn $ show comp1
  --putStrLn $ show comp2
  let edges = newEdges n comp1 comp2
  print $ length edges
  forM_ edges $ \(i,j) -> do
    putStrLn ((show i) ++ " " ++ (show j))


Let $$$F_k$$$ denote the $$$k$$$-th term of Fibonacci sequence, defined as below: $$$F_0 = F_1 = 1$$$ for any integer $$$n \geq 0$$$, $$$F_{n+2} = F_{n+1} + F_n$$$You are given a tree with $$$n$$$ vertices. Recall that a tree is a connected undirected graph without cycles.We call a tree a Fib-tree, if its number of vertices equals $$$F_k$$$ for some $$$k$$$, and at least one of the following conditions holds: The tree consists of only $$$1$$$ vertex; You can divide it into two Fib-trees by removing some edge of the tree. Determine whether the given tree is a Fib-tree or not.

The first line of the input contains a single integer $$$n$$$ ($$$1 \leq n \leq 2 \cdot 10^5$$$) — the number of vertices in the tree. Then $$$n-1$$$ lines follow, each of which contains two integers $$$u$$$ and $$$v$$$ ($$$1\leq u,v \leq n$$$, $$$u \neq v$$$), representing an edge between vertices $$$u$$$ and $$$v$$$. It's guaranteed that given edges form a tree.

Print "YES" if the given tree is a Fib-tree, or "NO" otherwise. You can print your answer in any case. For example, if the answer is "YES", then the output "Yes" or "yeS" will also be considered as correct answer.

NoteIn the first sample, we can cut the edge $$$(1, 2)$$$, and the tree will be split into $$$2$$$ trees of sizes $$$1$$$ and $$$2$$$ correspondently. Any tree of size $$$2$$$ is a Fib-tree, as it can be split into $$$2$$$ trees of size $$$1$$$.In the second sample, no matter what edge we cut, the tree will be split into $$$2$$$ trees of sizes $$$1$$$ and $$$4$$$. As $$$4$$$ isn't $$$F_k$$$ for any $$$k$$$, it's not Fib-tree.In the third sample, here is one possible order of cutting the edges so that all the trees in the process are Fib-trees: $$$(1, 3), (1, 2), (4, 5), (3, 4)$$$.

{-# LANGUAGE BangPatterns #-}
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

import Data.Array.Unboxed
import Data.Array.ST.Safe
import Control.Monad.ST

fibs :: [Int]
fibs = 1 : 1 : zipWith (+) fibs (tail fibs)

type Graph = Array Int [Int]
type IntArr = UArray Int Int
type STIntArr s = STUArray s Int Int

initialDFS :: Graph -> STIntArr s -> STIntArr s -> Int -> Int -> ST s Int
initialDFS adj sizeArr parentArr parent curr = let
  children = [v | v <- adj ! curr, v /= parent]
  step !prevTot child = do
    childSize <- initialDFS adj sizeArr parentArr curr child
    pure $ prevTot + childSize
  in  do
  writeArray parentArr curr parent
  size <- foldM step 1 children
  size <$ writeArray sizeArr curr size

partitionDFS :: Graph -> STIntArr s -> Int -> Int -> Int -> Int -> ST s ()
partitionDFS adj parts currPart label parent curr = let
  step n = (>>) $ when (n /= parent) $ do
    npart <- readArray parts n
    when (npart == currPart) $ partitionDFS adj parts currPart label curr n
  in  foldr step (writeArray parts curr label) $ adj ! curr

solve :: Graph -> IntArr -> Bool
solve adj prevFibs = let
  -- much nastier mutable-array implementation,
  -- to avoid un-necessary copying, etc.
  go :: (STIntArr s, STIntArr s, STIntArr s, IntArr) -> ST s Bool
  go arg@(sizeArr, parts, splitPtArr, parentArr) = do
    allRoots <- filterM (\v -> (== v) <$> readArray parts v) (indices adj)
    roots <- filterM (fmap (> 3) . readArray sizeArr) allRoots
    -- find split points
    forM_ roots $ \root -> writeArray splitPtArr root (0-1)
    forM_ (indices adj) $ \v -> do
      vRoot <- readArray parts v
      vSize <- readArray sizeArr v
      vRootSize <- readArray sizeArr vRoot
      let  tarSize = prevFibs ! vRootSize
      when (tarSize == vSize || tarSize == vRootSize - vSize)
        $ writeArray splitPtArr vRoot v
    -- perform splits
    ok <- forM roots $ \currRoot -> do
      splitPt <- readArray splitPtArr currRoot
      if  inRange (bounds adj) splitPt
        then  let
        splitPtPar = parentArr ! splitPt
        splitPtAncestors = currRoot
          : takeWhile (/= currRoot) (iterate (parentArr !) splitPtPar)
        in  True <$ do
        partitionDFS adj parts currRoot splitPt splitPtPar splitPt
        splitPtSize <- readArray sizeArr splitPt
        forM_ splitPtAncestors $ \ancestor -> do
          val <- readArray sizeArr ancestor
          writeArray sizeArr ancestor (val - splitPtSize)
        else  pure False
    if  null roots
      then  pure True
      else  if  and ok
      then  go arg
      else  pure False
  in  runST $ do
  let  root = fst $ bounds adj
  sizeArr <- newArray_ (bounds adj)
  parts <- newArray (bounds adj) root
  splitPtArr <- newArray_ (bounds adj)
  parentMutArr <- newArray_ (bounds adj)
  _ <- initialDFS adj sizeArr parentMutArr (0-1) root
  parentArr <- freeze parentMutArr
  go (sizeArr, parts, splitPtArr, parentArr)

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [n] <- readInts
  edges <- fmap concat $ replicateM (n-1) $ do
    [u, v] <- readInts
    pure [(u, v), (v, u)]
  let
    nFibs = takeWhile (<= n) fibs
    prevFibs :: IntArr
    prevFibs = accumArray (\_ v -> v) (0-1) (1, n) $ zip (tail nFibs) nFibs
    adj :: Graph
    adj = accumArray (flip (:)) [] (1, n) edges
  lift $ P.putStrLn $ if  solve adj prevFibs
    then  P.pack "YES"
    else  P.pack "NO"

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 a binary string $$$s$$$ of length $$$n$$$.Let's define $$$d_i$$$ as the number whose decimal representation is $$$s_i s_{i+1}$$$ (possibly, with a leading zero). We define $$$f(s)$$$ to be the sum of all the valid $$$d_i$$$. In other words, $$$f(s) = \sum\limits_{i=1}^{n-1} d_i$$$.For example, for the string $$$s = 1011$$$:   $$$d_1 = 10$$$ (ten);  $$$d_2 = 01$$$ (one)  $$$d_3 = 11$$$ (eleven);  $$$f(s) = 10 + 01 + 11 = 22$$$. In one operation you can swap any two adjacent elements of the string. Find the minimum value of $$$f(s)$$$ that can be achieved if at most $$$k$$$ operations are allowed.

Each test contains multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \le t \le 10^5$$$). Description of the test cases follows. First line of each test case contains two integers $$$n$$$ and $$$k$$$ ($$$2 \le n \le 10^5$$$, $$$0 \le k \le 10^9$$$) — the length of the string and the maximum number of operations allowed. The second line of each test case contains the binary string $$$s$$$ of length $$$n$$$, consisting of only zeros and ones. It is also given that sum of $$$n$$$ over all the test cases doesn't exceed $$$10^5$$$.

For each test case, print the minimum value of $$$f(s)$$$ you can obtain with at most $$$k$$$ operations.

Note  For the first example, you can't do any operation so the optimal string is $$$s$$$ itself. $$$f(s) = f(1010) = 10 + 01 + 10 = 21$$$.  For the second example, one of the optimal strings you can obtain is "0011000". The string has an $$$f$$$ value of $$$22$$$.  For the third example, one of the optimal strings you can obtain is "00011". The string has an $$$f$$$ value of $$$12$$$.

{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, UndecidableSuperClasses, MultiWayIf, KindSignatures,
OverloadedLists,ApplicativeDo,OverloadedStrings,MonadComprehensions,ParallelListComp,TransformListComp, TupleSections,
BlockArguments, TypeApplications, PostfixOperators, TypeOperators, BangPatterns, LambdaCase, UnboxedSums, UnboxedTuples, RankNTypes,
FlexibleContexts,DeriveFoldable, DeriveTraversable, ScopedTypeVariables, GADTs, PatternSynonyms, ViewPatterns, FunctionalDependencies #-}
import Data.List (group, sort, groupBy, partition)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Function ((&),fix,on)
import Data.Maybe (fromJust, isNothing)
import Data.Bifunctor (bimap)
import GHC.Int (Int64)
int :: L.ByteString -> Int
int = fst . fromJust . L.readInt
readInts ::L.ByteString -> [Int]
readInts = map int . L.split ' '

-- solve :: [Int] -> L.ByteString
-- solve = L.pack . show . uncurry min . bimap length length . partition even

twos :: [L.ByteString] -> [(Int,Int,L.ByteString)]
twos [] = []
twos (x:y:xs) = (a,b,y) : twos xs
 where (a:b:_) = readInts x

process :: L.ByteString -> (Maybe (Int,Int), Int)
process xs = (f $ L.elemIndices '1' xs, 11* (fromIntegral $ L.count '1' xs))
 where f :: [Int64] -> Maybe (Int,Int)
       f []      = Nothing
       f [x]     = Just (1+fromIntegral x,1+fromIntegral x)
       f (x:zs)  = Just (1+fromIntegral x,succ$fromIntegral $ last zs)

solve'::(Maybe (Int,Int),Int) -> Int -> Int -> Int
solve' (Just (a, b), points) len k
 | points' == 1 = 1 --moved only 1 to far right
 | k' >= a - 1  = pred points'
 | otherwise    = points'
 where (k',points') = if k >= len - b then (k - (len - b),points-10) else (k,points)
solve' _ _ _ = 0

solve :: (Int, Int, L.ByteString) -> Int
solve (len,k,xs) = solve' (process xs) len k

main :: IO ()
main = do (n:xs) <- L.lines <$> L.getContents
          L.putStr . L.unlines . map (L.pack.show.solve) . twos $ take (2*int n) xs

    --L.interact (L.unlines . map (solve . readInts) . twos . tail . L.lines)

calculate :: String -> Int
calculate [_] = 0
calculate s = (read (take 2 s) :: Int) + calculate (drop 1 s)

search :: Eq t => Int -> t -> [t] -> Int
search i k [] = -1
search i k (x : xs)
 | (k == x) = i
 | otherwise = search (i + 1) k xs

indexOf :: Eq t => t -> [t] -> Int
indexOf k a = search 0 k a

lastIndexOf :: Eq t => t -> [t] -> Int
lastIndexOf k a
 | (index > -1) = (length a) - 1 - index
 | otherwise = -1
 where
  index = indexOf k (reverse a)

ans :: IO String
ans = do
 nkInput <- getLine
 sInput <- getLine
 let (n : k : []) = [read x :: Int | x <- words nkInput]
 let s = sInput
 let lastIndex = lastIndexOf '1' s
 let firstIndex = indexOf '1' s
 let needLast = n - 1 - lastIndex
 let needFirst = firstIndex
 let total = calculate s
 if lastIndex == -1 then do
  return "0"
 else if (lastIndex == firstIndex) then do
  if (k == 0) || (k < min needLast needFirst) then do
   return (show total)
  else if (needLast == 0) || (k >= needLast) then do
   return "1"
  else if (k >= needFirst) then do
   return "10"
  else do
   return "must have else 1"
 else if (k == 0) || (needLast == 0 && needFirst == 0) || (k < min needLast needFirst) || (needFirst == 0 && k < needLast) || (needLast == 0 && k < needFirst) then do
  return (show total)
 else if (needLast > 0) && (k >= needLast) && (needFirst > 0) && (k - needLast >= needFirst) then do
  return (show (total - 11))
 else if (needLast > 0) && (k >= needLast) && (needFirst == 0 || k - needLast < needFirst) then do
  return (show (total - 10))
 else if (needLast == 0 || k < needLast) && (needFirst > 0) && (k >= needFirst) then do
  return (show (total - 1))
 else do
  return "must have else 2"

main :: IO ()
main = do
 tInput <- getLine
 let t = read tInput :: Int
 results <- sequence (replicate t ans)
 putStrLn (unwords results)


Kilani and Abd are neighbors for 3000 years, but then the day came and Kilani decided to move to another house. As a farewell gift, Kilani is going to challenge Abd with a problem written by their other neighbor with the same name Abd.  The problem is:You are given a connected tree rooted at node $$$1$$$.You should assign a character a or b to every node in the tree so that the total number of a's is equal to $$$x$$$ and the total number of b's is equal to $$$n - x$$$.Let's define a string for each node $$$v$$$ of the tree as follows:   if $$$v$$$ is root then the string is just one character assigned to $$$v$$$:  otherwise, let's take a string defined for the $$$v$$$'s parent $$$p_v$$$ and add to the end of it a character assigned to $$$v$$$. You should assign every node a character in a way that minimizes the number of distinct strings among the strings of all nodes.

The first line contains two integers $$$n$$$ and $$$x$$$ ($$$1 \leq n \leq 10^5$$$; $$$0 \leq x \leq n$$$) — the number of vertices in the tree the number of a's. The second line contains $$$n - 1$$$ integers $$$p_2, p_3, \dots, p_{n}$$$ ($$$1 \leq p_i \leq n$$$; $$$p_i \neq i$$$), where $$$p_i$$$ is the parent of node $$$i$$$. It is guaranteed that the input describes a connected tree.

In the first line, print the minimum possible total number of distinct strings. In the second line, print $$$n$$$ characters, where all characters are either a or b and the $$$i$$$-th character is the character assigned to the $$$i$$$-th node. Make sure that the total number of a's is equal to $$$x$$$ and the total number of b's is equal to $$$n - x$$$. If there is more than one answer you can print any of them.

NoteThe tree from the sample is shown below:  The tree after assigning characters to every node (according to the output) is the following:  Strings for all nodes are the following:   string of node $$$1$$$ is: a  string of node $$$2$$$ is: aa  string of node $$$3$$$ is: aab  string of node $$$4$$$ is: aab  string of node $$$5$$$ is: aabb  string of node $$$6$$$ is: aabb  string of node $$$7$$$ is: aabb  string of node $$$8$$$ is: aabb  string of node $$$9$$$ is: aa The set of unique strings is $$$\{\text{a}, \text{aa}, \text{aab}, \text{aabb}\}$$$, so the number of distinct strings is $$$4$$$.

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class

import qualified Data.ByteString.Lazy.Char8 as P

import Data.Array.Unboxed
import Data.Array.ST.Safe
import Control.Monad.ST

type SIO = StateT P.ByteString IO

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

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

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

size :: Tree t -> Int
size (Leaf _) = 1
size (Node sz _ _) = sz

unite :: Tree t -> Tree t -> Tree t
unite x y = Node (size x + size y) x y

fromList :: [t] -> Tree t
fromList [] = error "fromList []"
fromList [x] = Leaf x
fromList (x:xs) = unite (Leaf x) $ fromList xs

toList :: Tree t -> [t]
toList = let
  go (Leaf x) = (x :)
  go (Node _ x y) = go x . go y
  in  flip go []

pairUp :: [Tree t] -> ([Tree t], [Tree t])
pairUp (x : y : zs@(_ : _)) = let
  (zpairs, unpaired) = pairUp zs
  in  (unite x y : zpairs, unpaired)
pairUp li = ([], li)

reduce :: [Tree t] -> [Tree t]
reduce [] = []
reduce li = runST $ do
  let  totSz = sum $ map size li
  arr <- newArray (1, totSz) [] :: ST s (STArray s Int [Tree t])
  forM_ li $ \v -> do
    let currSz = size v
    prev <- readArray arr currSz
    writeArray arr currSz (v : prev)
  forM_ [1..totSz] $ \currSz -> do
    szOpts <- readArray arr currSz
    let  (paired, unpaired) = pairUp szOpts
    writeArray arr currSz unpaired
    when (not $ null paired) $ do
      nextOpts <- readArray arr (2*currSz)
      -- (++) isn't cheap here, but it's only O(n * log n) complete
      -- cost, so not worth using some abstraction to avoid its overhead
      writeArray arr (2*currSz) $ paired ++ nextOpts
  allOpts <- getElems arr
  pure $ concat allOpts

solve :: [Tree Int] -> Int -> Maybe [Int]
solve options target = let
  memo = runSTUArray $ do
    arr <- newArray (0, target) 0 :: ST s (STUArray s Int Int)
    writeArray arr 0 (0-1)
    forM_ options $ \currOpt -> do
      let  s = size currOpt
      forM_ (takeWhile (>= 0) $ iterate (subtract 1) (target-s)) $ \i -> do
        prevStep <- readArray arr i
        when (prevStep /= 0) $ do
          oldVal <- readArray arr (i+s)
          writeArray arr (i+s) $ if  oldVal > 0  then  oldVal  else  s
    pure arr
  go 0 = Just []
  go k = let
    s = memo ! k
    in  if  s == 0
      then  Nothing
      else  (s :) <$> go (k - s)
  collectResult [] _ = []
  collectResult (sz : szs) toSearch
    = case  dropWhile (\x -> size x /= sz) toSearch  of
    [] -> error "not found?!"
    curr : rest -> toList curr ++ collectResult szs rest
  in  do
  sizes <- go target
  pure $ collectResult (reverse sizes) options

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [n, origX] <- readInts
  pLi <- readInts
  let
    x = min origX (n - origX)
    depths :: Array Int Int
    depths = listArray (1, n) $ 1 : map (\p -> 1 + depths ! p) pLi
    maxDepth = maximum $ elems depths
    findByDepth :: Array Int [Int]
    findByDepth = accumArray (flip (:)) [] (1, maxDepth)
                  [(d, ix) | (ix, d) <- assocs depths]
    isLeaf :: UArray Int Bool
    isLeaf = accumArray (\_ _ -> False) True (1, n) $ zip pLi (repeat ())
    unreducedOptions = [fromList li | li <- elems findByDepth, not $ null li]
    options = reduce unreducedOptions
    solution = solve options x
    toByteString :: [Int] -> P.ByteString
    toByteString li = let
        arr :: UArray Int Char
        arr = if  x == origX
          then  accumArray (\_ _ -> 'a') 'b' (1, n) $ zip li (repeat ())
          else  accumArray (\_ _ -> 'b') 'a' (1, n) $ zip li (repeat ())
        in  P.pack $ elems arr
    imperfectSoln = let
      go 0 0 [] = []
      go _ _ [] = error "???"
      go asLeft bsLeft (v:vs) = let
        currLen = length v
        currLeaves = filter (isLeaf !) v
        currLeafCt = length currLeaves
        currNonLeaves = filter (not . (isLeaf !)) v
        in  if  currLen <= asLeft
        then  v ++ go (asLeft - currLen) bsLeft vs
        else  if  currLen <= bsLeft
        then       go asLeft (bsLeft - currLen) vs
        else  if  currLeafCt >= asLeft
        then  take asLeft currLeaves
        else  if  currLeafCt >= bsLeft
        then  drop bsLeft currLeaves ++ currNonLeaves ++ concat vs
        else  error "this shouldn't be possible"
      in  go x (n-x) $ elems findByDepth
    (score, str) = case  solution  of
      Just li -> (maxDepth, toByteString li)
      Nothing -> (maxDepth + 1, toByteString imperfectSoln)
  lift . P.putStrLn . P.pack $ show score
  lift . P.putStrLn $ str

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class

import qualified Data.ByteString.Lazy.Char8 as P

import Data.Array.Unboxed
import Data.Array.ST.Safe
import Control.Monad.ST

type SIO = StateT P.ByteString IO

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

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

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

size :: Tree t -> Int
size (Leaf _) = 1
size (Node sz _ _) = sz

unite :: Tree t -> Tree t -> Tree t
unite x y = Node (size x + size y) x y

fromList :: [t] -> Tree t
fromList [] = error "fromList []"
fromList [x] = Leaf x
fromList (x:xs) = unite (Leaf x) $ fromList xs

toList :: Tree t -> [t]
toList = let
  go (Leaf x) = (x :)
  go (Node _ x y) = go x . go y
  in  flip go []

pairUp :: [Tree t] -> ([Tree t], [Tree t])
pairUp (x : y : zs@(_ : _)) = let
  (zpairs, unpaired) = pairUp zs
  in  (unite x y : zpairs, unpaired)
pairUp li = ([], li)

reduce :: [Tree t] -> [Tree t]
reduce [] = []
reduce li = runST $ do
  let  totSz = sum $ map size li
  arr <- newArray (1, totSz) [] :: ST s (STArray s Int [Tree t])
  forM_ li $ \v -> do
    let currSz = size v
    prev <- readArray arr currSz
    writeArray arr currSz (v : prev)
  forM_ [1..totSz] $ \currSz -> do
    szOpts <- readArray arr currSz
    let  (paired, unpaired) = pairUp szOpts
    writeArray arr currSz unpaired
    when (not $ null paired) $ do
      nextOpts <- readArray arr (2*currSz)
      -- (++) isn't cheap here, but it's only O(n * log n) complete
      -- cost, so not worth using some abstraction to avoid its overhead
      writeArray arr (2*currSz) $ paired ++ nextOpts
  allOpts <- getElems arr
  pure $ concat allOpts

solve :: [Tree Int] -> Int -> Maybe [Int]
solve options target = let
  memo = runSTUArray $ do
    arr <- newArray (0, target) 0 :: ST s (STUArray s Int Int)
    writeArray arr 0 (0-1)
    forM_ options $ \currOpt -> do
      let  s = size currOpt
      forM_ (reverse [0 .. target-s]) $ \i -> do
        prevStep <- readArray arr i
        when (prevStep /= 0) $ do
          oldVal <- readArray arr (i+s)
          writeArray arr (i+s) $ if  oldVal > 0  then  oldVal  else  s
    pure arr
  go 0 = Just []
  go k = let
    s = memo ! k
    in  if  s == 0
      then  Nothing
      else  (s :) <$> go (k - s)
  collectResult [] _ = []
  collectResult (sz : szs) toSearch
    = case  dropWhile (\x -> size x /= sz) toSearch  of
    [] -> error "not found?!"
    curr : rest -> toList curr ++ collectResult szs rest
  in  do
  sizes <- go target
  pure $ collectResult (reverse sizes) options

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [n, origX] <- readInts
  pLi <- readInts
  let
    x = min origX (n - origX)
    depths :: Array Int Int
    depths = listArray (1, n) $ 1 : map (\p -> 1 + depths ! p) pLi
    maxDepth = maximum $ elems depths
    findByDepth :: Array Int [Int]
    findByDepth = accumArray (flip (:)) [] (1, maxDepth)
                  [(d, ix) | (ix, d) <- assocs depths]
    isLeaf :: UArray Int Bool
    isLeaf = accumArray (\_ _ -> False) True (1, n) $ zip pLi (repeat ())
    unreducedOptions = [fromList li | li <- elems findByDepth, not $ null li]
    options = reduce unreducedOptions
    solution = solve options x
    toByteString :: [Int] -> P.ByteString
    toByteString li = let
        arr :: UArray Int Char
        arr = if  x == origX
          then  accumArray (\_ _ -> 'a') 'b' (1, n) $ zip li (repeat ())
          else  accumArray (\_ _ -> 'b') 'a' (1, n) $ zip li (repeat ())
        in  P.pack $ elems arr
    imperfectSoln = let
      go 0 0 [] = []
      go _ _ [] = error "???"
      go asLeft bsLeft (v:vs) = let
        currLen = length v
        currLeaves = filter (isLeaf !) v
        currLeafCt = length currLeaves
        currNonLeaves = filter (not . (isLeaf !)) v
        in  if  currLen <= asLeft
        then  v ++ go (asLeft - currLen) bsLeft vs
        else  if  currLen <= bsLeft
        then       go asLeft (bsLeft - currLen) vs
        else  if  currLeafCt >= asLeft
        then  take asLeft currLeaves
        else  if  currLeafCt >= bsLeft
        then  drop bsLeft currLeaves ++ currNonLeaves ++ concat vs
        else  error "this shouldn't be possible"
      in  go x (n-x) $ elems findByDepth
    (score, str) = case  solution  of
      Just li -> (maxDepth, toByteString li)
      Nothing -> (maxDepth + 1, toByteString imperfectSoln)
  lift . P.putStrLn . P.pack $ show score
  lift . P.putStrLn $ str
  let
    as = P.filter (== 'a') str
  when (P.length as /= fromIntegral x) $ lift . P.putStrLn . P.pack $ "Yikes"

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class

import qualified Data.ByteString.Lazy.Char8 as P

import Data.Array.Unboxed
import Data.Array.ST.Safe
import Control.Monad.ST

type SIO = StateT P.ByteString IO

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

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

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

size :: Tree t -> Int
size (Leaf _) = 1
size (Node sz _ _) = sz

unite :: Tree t -> Tree t -> Tree t
unite x y = Node (size x + size y) x y

fromList :: [t] -> Tree t
fromList [] = error "fromList []"
fromList [x] = Leaf x
fromList (x:xs) = unite (Leaf x) $ fromList xs

toList :: Tree t -> [t]
toList = let
  go (Leaf x) = (x :)
  go (Node _ x y) = go x . go y
  in  flip go []

pairUp :: [Tree t] -> ([Tree t], [Tree t])
pairUp (x : y : zs@(_ : _)) = let
  (zpairs, unpaired) = pairUp zs
  in  (unite x y : zpairs, unpaired)
pairUp li = ([], li)

reduce :: [Tree t] -> [Tree t]
reduce [] = []
reduce li = runST $ do
  let  totSz = sum $ map size li
  arr <- newArray (1, totSz) [] :: ST s (STArray s Int [Tree t])
  forM_ li $ \v -> do
    let currSz = size v
    prev <- readArray arr currSz
    writeArray arr currSz (v : prev)
  forM_ [1..totSz] $ \currSz -> do
    szOpts <- readArray arr currSz
    let  (paired, unpaired) = pairUp szOpts
    writeArray arr currSz unpaired
    when (not $ null paired) $ do
      nextOpts <- readArray arr (2*currSz)
      -- (++) isn't cheap here, but it's only O(n * log n) complete
      -- cost, so not worth using some abstraction to avoid its overhead
      writeArray arr (2*currSz) $ paired ++ nextOpts
  allOpts <- getElems arr
  pure $ concat allOpts

solve :: [Tree Int] -> Int -> Maybe [Int]
solve options target = let
  memo = runSTUArray $ do
    arr <- newArray (0, target) 0 :: ST s (STUArray s Int Int)
    writeArray arr 0 (0-1)
    forM_ options $ \currOpt -> do
      let  s = size currOpt
      forM_ (reverse [0 .. target-s]) $ \i -> do
        prevStep <- readArray arr i
        when (prevStep /= 0) $ do
          oldVal <- readArray arr (i+s)
          writeArray arr (i+s) $ if  oldVal > 0  then  oldVal  else  s
    pure arr
  go 0 = Just []
  go k = let
    s = memo ! k
    in  if  s == 0
      then  Nothing
      else  (s :) <$> go (k - s)
  collectResult [] _ = []
  collectResult (sz : szs) toSearch
    = case  dropWhile (\x -> size x /= sz) toSearch  of
    [] -> error "not found?!"
    curr : rest -> toList curr ++ collectResult szs rest
  in  do
  sizes <- go target
  pure $ collectResult (reverse sizes) options

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [n, x] <- readInts
  pLi <- readInts
  let
    depths :: Array Int Int
    depths = listArray (1, n) $ 1 : map (\p -> 1 + depths ! p) pLi
    maxDepth = maximum $ elems depths
    findByDepth :: Array Int [Int]
    findByDepth = accumArray (flip (:)) [] (1, maxDepth)
                  [(d, ix) | (ix, d) <- assocs depths]
    isLeaf :: UArray Int Bool
    isLeaf = accumArray (\_ _ -> False) True (1, n) $ zip pLi (repeat ())
    unreducedOptions = [fromList li | li <- elems findByDepth, not $ null li]
    options = reduce unreducedOptions
    solution = solve options x
    toByteString :: [Int] -> P.ByteString
    toByteString li = let
        arr :: UArray Int Char
        arr = accumArray (\_ _ -> 'a') 'b' (1, n) $ zip li (repeat ())
        in  P.pack $ elems arr
    imperfectSoln = let
      go 0 0 [] = []
      go _ _ [] = error "???"
      go asLeft bsLeft (v:vs) = let
        currLen = length v
        currLeaves = filter (isLeaf !) v
        currLeafCt = length currLeaves
        in  if  currLen <= asLeft
        then  v ++ go (asLeft - currLen) bsLeft vs
        else  if  currLen <= bsLeft
        then       go asLeft (bsLeft - currLen) vs
        else  if  currLeafCt >= asLeft
        then  take asLeft currLeaves
        else  if  currLeafCt >= bsLeft
        then  drop bsLeft currLeaves ++ concat vs
        else  error "this shouldn't be possible"
      in  go x (n-x) $ elems findByDepth
    (score, str) = case  solution  of
      Just li -> (maxDepth, toByteString li)
      Nothing -> (maxDepth + 1, toByteString imperfectSoln)
  lift . P.putStrLn . P.pack $ show score
  lift . P.putStrLn $ str

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class

import qualified Data.ByteString.Lazy.Char8 as P

import Data.Array.Unboxed
import Data.Array.ST.Safe
import Control.Monad.ST

type SIO = StateT P.ByteString IO

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

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

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

size :: Tree t -> Int
size (Leaf _) = 1
size (Node sz _ _) = sz

unite :: Tree t -> Tree t -> Tree t
unite x y = Node (size x + size y) x y

fromList :: [t] -> Tree t
fromList [] = error "fromList []"
fromList [x] = Leaf x
fromList (x:xs) = unite (Leaf x) $ fromList xs

toList :: Tree t -> [t]
toList = let
  go (Leaf x) = (x :)
  go (Node _ x y) = go x . go y
  in  flip go []

pairUp :: [Tree t] -> ([Tree t], [Tree t])
pairUp (x : y : zs@(_ : _)) = let
  (zpairs, unpaired) = pairUp zs
  in  (unite x y : zpairs, unpaired)
pairUp li = ([], li)

reduce :: [Tree t] -> [Tree t]
reduce [] = []
reduce li = runST $ do
  let  totSz = sum $ map size li
  arr <- newArray (1, totSz) [] :: ST s (STArray s Int [Tree t])
  forM_ li $ \v -> do
    let currSz = size v
    prev <- readArray arr currSz
    writeArray arr currSz (v : prev)
  forM_ [1..totSz] $ \currSz -> do
    szOpts <- readArray arr currSz
    let  (paired, unpaired) = pairUp szOpts
    writeArray arr currSz unpaired
    when (not $ null paired) $ do
      nextOpts <- readArray arr (2*currSz)
      -- (++) isn't cheap here, but it's only O(n * log n) complete
      -- cost, so not worth using some abstraction to avoid its overhead
      writeArray arr (2*currSz) $ paired ++ nextOpts
  allOpts <- getElems arr
  pure $ concat allOpts

solve :: [Tree Int] -> Int -> Maybe [Int]
solve options target = let
  memo = runSTUArray $ do
    arr <- newArray (0, target) 0 :: ST s (STUArray s Int Int)
    writeArray arr 0 (0-1)
    forM_ options $ \currOpt -> do
      let  s = size currOpt
      forM_ (reverse [0 .. target-s]) $ \i -> do
        prevStep <- readArray arr i
        when (prevStep /= 0) $ do
          oldVal <- readArray arr (i+s)
          writeArray arr (i+s) $ if  oldVal > 0  then  oldVal  else  s
    pure arr
  go 0 = Just []
  go k = let
    s = memo ! k
    in  if  s == 0
      then  Nothing
      else  (s :) <$> go (k - s)
  collectResult [] _ = []
  collectResult (sz : szs) toSearch
    = case  dropWhile (\x -> size x /= sz) toSearch  of
    [] -> error "not found?!"
    curr : rest -> toList curr ++ collectResult szs rest
  in  do
  sizes <- go target
  pure $ collectResult (reverse sizes) options

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [n, x] <- readInts
  pLi <- readInts
  let
    depths :: Array Int Int
    depths = listArray (1, n) $ 1 : map (\p -> 1 + depths ! p) pLi
    maxDepth = maximum $ elems depths
    findByDepth :: Array Int [Int]
    findByDepth = accumArray (flip (:)) [] (1, maxDepth)
                  [(d, ix) | (ix, d) <- assocs depths]
    unreducedOptions = [fromList li | li <- elems findByDepth, not $ null li]
    options = reduce unreducedOptions
    solution = solve options x
    toByteString :: [Int] -> P.ByteString
    toByteString li = let
        arr :: UArray Int Char
        arr = accumArray (\_ _ -> 'a') 'b' (1, n) $ zip li (repeat ())
        in  P.pack $ elems arr
    imperfectSoln = let
      go as xleft [v] = take xleft v ++ as
      go _ _ [] = error "???"
      go as xleft (v:vs) = let
        newxleft = xleft - length v
        in  if  newxleft >= 0
        then  go (v ++ as) newxleft vs
        else  go as xleft vs -- old xleft, intentional
      in  go [] x $ elems findByDepth
    (score, str) = case  solution  of
      Just li -> (maxDepth, toByteString li)
      Nothing -> (maxDepth + 1, toByteString imperfectSoln)
  lift . P.putStrLn . P.pack $ show score
  lift . P.putStrLn $ str

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class

import qualified Data.ByteString.Lazy.Char8 as P

import Data.Array.Unboxed
import Data.Array.ST.Safe
import Control.Monad.ST

type SIO = StateT P.ByteString IO

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

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

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

size :: Tree t -> Int
size (Leaf _) = 1
size (Node sz _ _) = sz

unite :: Tree t -> Tree t -> Tree t
unite x y = Node (size x + size y) x y

fromList :: [t] -> Tree t
fromList [] = error "fromList []"
fromList [x] = Leaf x
fromList (x:xs) = unite (Leaf x) $ fromList xs

toList :: Tree t -> [t]
toList = let
  go (Leaf x) = (x :)
  go (Node _ x y) = go x . go y
  in  flip go []

pairUp :: [Tree t] -> ([Tree t], [Tree t])
pairUp (x : y : zs@(_ : _)) = let
  (zpairs, unpaired) = pairUp zs
  in  (unite x y : zpairs, unpaired)
pairUp li = ([], li)

reduce :: [Tree t] -> [Tree t]
reduce [] = []
reduce li = runST $ do
  let  totSz = sum $ map size li
  arr <- newArray (1, totSz) [] :: ST s (STArray s Int [Tree t])
  forM_ li $ \v -> do
    let currSz = size v
    prev <- readArray arr currSz
    writeArray arr currSz (v : prev)
  forM_ [1..totSz] $ \currSz -> do
    szOpts <- readArray arr currSz
    let  (paired, unpaired) = pairUp szOpts
    writeArray arr currSz unpaired
    when (not $ null paired) $ do
      nextOpts <- readArray arr (2*currSz)
      -- (++) isn't cheap here, but it's only O(n * log n) complete
      -- cost, so not worth using some abstraction to avoid its overhead
      writeArray arr (2*currSz) $ paired ++ nextOpts
  allOpts <- getElems arr
  pure $ concat allOpts

solve :: [Tree Int] -> Int -> Maybe [Int]
solve options target = let
  memo = runSTUArray $ do
    arr <- newArray (0, target) 0 :: ST s (STUArray s Int Int)
    writeArray arr 0 (0-1)
    forM_ options $ \currOpt -> do
      let  s = size currOpt
      forM_ (reverse [0 .. target-s]) $ \i -> do
        prevStep <- readArray arr i
        when (prevStep /= 0) $ do
          oldVal <- readArray arr (i+s)
          writeArray arr (i+s) $ if  oldVal > 0  then  oldVal  else  s
    pure arr
  go 0 = Just []
  go k = let
    s = memo ! k
    in  if  s == 0
      then  Nothing
      else  (s :) <$> go (k - s)
  collectResult [] _ = []
  collectResult (sz : szs) toSearch
    = case  dropWhile (\x -> size x /= sz) toSearch  of
    [] -> error "not found?!"
    curr : rest -> toList curr ++ collectResult szs rest
  in  do
  sizes <- go target
  pure $ collectResult (reverse sizes) options

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [n, x] <- readInts
  pLi <- readInts
  let
    depths :: Array Int Int
    depths = listArray (1, n) $ 1 : map (\p -> 1 + depths ! p) pLi
    maxDepth = maximum $ elems depths
    findByDepth :: Array Int [Int]
    findByDepth = accumArray (flip (:)) [] (1, maxDepth)
                  [(d, ix) | (ix, d) <- assocs depths]
    unreducedOptions = [fromList li | li <- elems findByDepth, not $ null li]
    options = reduce unreducedOptions
    solution = solve options x
    toByteString :: [Int] -> P.ByteString
    toByteString li = let
        arr :: UArray Int Char
        arr = accumArray (\_ _ -> 'a') 'b' (1, n) $ zip li (repeat ())
        in  P.pack $ elems arr
    (score, str) = case  solution  of
      Just li -> (maxDepth, toByteString li)
      Nothing -> (maxDepth + 1,
                  toByteString . take x . concat $ elems findByDepth)
  let
    count li = let
      av = elem 'a' $ P.index str . fromIntegral . (subtract 1) <$> li
      bv = elem 'b' $ P.index str . fromIntegral . (subtract 1) <$> li
      in  case  (av, bv)  of
      (False, False) -> error "huh?"
      (True, True) -> 2
      _ -> 1
    approxScore = sum [count li | li <- elems findByDepth, not (null li)]
  -- This should be triggered if there are the wrong number of distinct strings
  -- If this doesn't activate on test case 12 I will be very confused
  -- But I haven't been able to trigger it on random test data, either...
  when (score /= approxScore) $ lift . P.putStrLn $ P.pack "Yikes\n"
  lift . P.putStrLn . P.pack $ show score
  lift . P.putStrLn $ str

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class

import qualified Data.ByteString.Lazy.Char8 as P

import Data.Array.Unboxed
import Data.Array.ST.Safe
import Control.Monad.ST

type SIO = StateT P.ByteString IO

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

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

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

size :: Tree t -> Int
size (Leaf _) = 1
size (Node sz _ _) = sz

unite :: Tree t -> Tree t -> Tree t
unite x y = Node (size x + size y) x y

fromList :: [t] -> Tree t
fromList [] = error "fromList []"
fromList [x] = Leaf x
fromList (x:xs) = unite (Leaf x) $ fromList xs

toList :: Tree t -> [t]
toList = let
  go (Leaf x) = (x :)
  go (Node _ x y) = go x . go y
  in  flip go []

pairUp :: [Tree t] -> ([Tree t], [Tree t])
pairUp (x : y : zs@(_ : _)) = let
  (zpairs, unpaired) = pairUp zs
  in  (unite x y : zpairs, unpaired)
pairUp li = ([], li)

reduce :: [Tree t] -> [Tree t]
reduce [] = []
reduce li = runST $ do
  let  totSz = sum $ map size li
  arr <- newArray (1, totSz) [] :: ST s (STArray s Int [Tree t])
  forM_ li $ \v -> do
    let currSz = size v
    prev <- readArray arr currSz
    writeArray arr currSz (v : prev)
  forM_ [1..totSz] $ \currSz -> do
    szOpts <- readArray arr currSz
    let  (paired, unpaired) = pairUp szOpts
    writeArray arr currSz unpaired
    when (not $ null paired) $ do
      nextOpts <- readArray arr (2*currSz)
      -- (++) isn't cheap here, but it's only O(n * log n) complete
      -- cost, so not worth using some abstraction to avoid its overhead
      writeArray arr (2*currSz) $ paired ++ nextOpts
  allOpts <- getElems arr
  pure $ concat allOpts

solve :: [Tree Int] -> Int -> Maybe [Int]
solve options target = let
  memo = runSTUArray $ do
    arr <- newArray (0, target) 0 :: ST s (STUArray s Int Int)
    writeArray arr 0 (0-1)
    forM_ options $ \currOpt -> do
      let  s = size currOpt
      forM_ (reverse [0 .. target-s]) $ \i -> do
        prevStep <- readArray arr i
        when (prevStep /= 0) $ do
          oldVal <- readArray arr (i+s)
          writeArray arr (i+s) $ if  oldVal > 0  then  oldVal  else  s
    pure arr
  go 0 = Just []
  go k = let
    s = memo ! k
    in  if  s == 0
      then  Nothing
      else  (s :) <$> go (k - s)
  collectResult [] _ = []
  collectResult (sz : szs) toSearch
    = case  dropWhile (\x -> size x /= sz) toSearch  of
    [] -> error "not found?!"
    curr : rest -> toList curr ++ collectResult szs rest
  in  do
  sizes <- go target
  pure $ collectResult (reverse sizes) options

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [n, x] <- readInts
  pLi <- readInts
  let
    depths :: Array Int Int
    depths = listArray (1, n) $ 1 : map (\p -> 1 + depths ! p) pLi
    maxDepth = maximum $ elems depths
    findByDepth :: Array Int [Int]
    findByDepth = accumArray (flip (:)) [] (1, maxDepth)
                  [(d, ix) | (ix, d) <- assocs depths]
    unreducedOptions = [fromList li | li <- elems findByDepth, not $ null li]
    options = reduce unreducedOptions
    solution = solve options x
    toByteString :: [Int] -> P.ByteString
    toByteString li = let
        arr :: UArray Int Char
        arr = accumArray (\_ _ -> 'a') 'b' (1, n) $ zip li (repeat ())
        in  P.pack $ elems arr
    (score, str) = case  solution  of
      Just li -> (maxDepth, toByteString li)
      Nothing -> (maxDepth + 1,
                  toByteString . take x . concat $ elems findByDepth)
  lift . P.putStrLn . P.pack $ show score
  lift . P.putStrLn $ str

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class

import qualified Data.ByteString.Lazy.Char8 as P

import Data.Array.Unboxed
import Data.Array.ST.Safe
import Control.Monad.ST

type SIO = StateT P.ByteString IO

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

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

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

size :: Tree t -> Int
size (Leaf _) = 1
size (Node sz _ _) = sz

unite :: Tree t -> Tree t -> Tree t
unite x y = Node (size x + size y) x y

fromList :: [t] -> Tree t
fromList [] = error "fromList []"
fromList [x] = Leaf x
fromList (x:xs) = unite (Leaf x) $ fromList xs

toList :: Tree t -> [t]
toList = let
  go (Leaf x) = (x :)
  go (Node _ x y) = go x . go y
  in  flip go []

pairUp :: [Tree t] -> ([Tree t], [Tree t])
pairUp (x : y : zs@(_ : _)) = let
  (zpairs, unpaired) = pairUp zs
  in  (unite x y : zpairs, unpaired)
pairUp li = ([], li)

reduce :: [Tree t] -> [Tree t]
reduce [] = []
reduce li = runST $ do
  let  totSz = sum $ map size li
  arr <- newArray (1, totSz) [] :: ST s (STArray s Int [Tree t])
  forM_ li $ \v -> do
    let currSz = size v
    prev <- readArray arr currSz
    writeArray arr currSz (v : prev)
  forM_ [1..totSz] $ \currSz -> do
    szOpts <- readArray arr currSz
    let  (paired, unpaired) = pairUp szOpts
    writeArray arr currSz unpaired
    when (not $ null paired) $ do
      nextOpts <- readArray arr (2*currSz)
      -- (++) isn't cheap here, but it's only O(n * log n) complete
      -- cost, so not worth using some abstraction to avoid its overhead
      writeArray arr (2*currSz) $ paired ++ nextOpts
  allOpts <- getElems arr
  pure $ concat allOpts

solve :: [Tree Int] -> Int -> Maybe [Int]
solve options target = let
  memo = runSTUArray $ do
    arr <- newArray (0, target) 0 :: ST s (STUArray s Int Int)
    writeArray arr 0 (0-1)
    forM_ options $ \currOpt -> do
      let  s = size currOpt
      forM_ (reverse [0 .. target-s]) $ \i -> do
        prevStep <- readArray arr i
        when (prevStep /= 0) $ do
          oldVal <- readArray arr (i+s)
          writeArray arr (i+s) $ if  oldVal > 0  then  oldVal  else  s
    pure arr
  go 0 = Just []
  go k = let
    s = memo ! k
    in  if  s == 0
      then  Nothing
      else  (s :) <$> go (k - s)
  collectResult [] _ = []
  collectResult (sz : szs) toSearch
    = case  dropWhile (\x -> size x /= sz) toSearch  of
    [] -> error "not found?!"
    curr : rest -> toList curr ++ collectResult szs rest
  in  do
  sizes <- go target
  pure $ collectResult (reverse sizes) options

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [n, x] <- readInts
  pLi <- readInts
  let
    depths :: Array Int Int
    depths = listArray (1, n) $ 1 : map (\p -> 1 + depths ! p) pLi
    maxDepth = maximum $ elems depths
    findByDepth :: Array Int [Int]
    findByDepth = accumArray (flip (:)) [] (1, maxDepth)
                  [(d, ix) | (ix, d) <- assocs depths]
    unreducedOptions = [fromList li | li <- elems findByDepth, not $ null li]
    options = reduce unreducedOptions
    solution = solve options x
    [n64, x64] = map fromIntegral [n, x]
    (score, str) = case  solution  of
      Nothing -> (maxDepth + 1,
                  P.concat [P.replicate x64 'a', P.replicate (n64 - x64) 'b'])
      Just li -> let
        arr :: UArray Int Char
        arr = accumArray (\_ _ -> 'a') 'b' (1, n) $ zip li (repeat ())
        in  (maxDepth, P.pack $ elems arr)
  lift . P.putStrLn . P.pack $ show score
  lift . P.putStrLn $ str


Polycarp has guessed three positive integers $$$a$$$, $$$b$$$ and $$$c$$$. He keeps these numbers in secret, but he writes down four numbers on a board in arbitrary order — their pairwise sums (three numbers) and sum of all three numbers (one number). So, there are four numbers on a board in random order: $$$a+b$$$, $$$a+c$$$, $$$b+c$$$ and $$$a+b+c$$$.You have to guess three numbers $$$a$$$, $$$b$$$ and $$$c$$$ using given numbers. Print three guessed integers in any order.Pay attention that some given numbers $$$a$$$, $$$b$$$ and $$$c$$$ can be equal (it is also possible that $$$a=b=c$$$).

The only line of the input contains four positive integers $$$x_1, x_2, x_3, x_4$$$ ($$$2 \le x_i \le 10^9$$$) — numbers written on a board in random order. It is guaranteed that the answer exists for the given number $$$x_1, x_2, x_3, x_4$$$.

Print such positive integers $$$a$$$, $$$b$$$ and $$$c$$$ that four numbers written on a board are values $$$a+b$$$, $$$a+c$$$, $$$b+c$$$ and $$$a+b+c$$$ written in some order. Print $$$a$$$, $$$b$$$ and $$$c$$$ in any order. If there are several answers, you can print any. It is guaranteed that the answer exists.

import Data.List (sort)

main = do
    line <- getLine
    let arr = sort $ map read $ words line
    putStrLn $ unwords $ map (show . (last arr -)) $ init arr

import Text.Printf
import Data.List

main = do
  n <- fmap (map read . words) getLine :: IO [Int]
  let l = sort n
  printf "%d %d %d" (l!!3 - l!!0) (l!!3 - l!!1) (l!!3 - l!!2)

merge :: Ord a => [a] -> [a] -> [a]
merge xs [] = xs
merge [] ys = ys
merge (x:xs) (y:ys) = (m : merge xs' ys')
  where
    m = min x y
    (xs',ys') = if x>y then (x:xs,ys) else (xs,y:ys)

mergesort :: Ord a => [a] -> [a]
mergesort (x:[]) = [x]
mergesort xs = merge (mergesort ys) (mergesort zs)
  where
    (ys,zs) = (take (n `quot` 2) xs, drop (n `quot` 2) xs)
    n = length xs

getInts :: IO [Int]
getInts  = do
  s <- getLine
  let iss = words s
  let is = map (\x -> read x :: Int) iss
  return is

f :: [Int] -> [Int]
f xs = [m-a,m-b,m-c]
  where
    [a,b,c,m] = mergesort xs

showI :: [Int] -> String
showI (x:[]) = show x
showI (x:xs) = show x ++ " " ++ showI xs

main :: IO ()
main = do
  ss <- getInts
  putStr.showI.f $ ss
  putStr "\n"

import Data.List
findem l = [(l !! 3) - (l !! 0), (l !! 3) - (l !! 1), (l !! 3) - (l !! 2)]
analyze = findem . sort
ans = unwords . (map show) . analyze . (map read) . words
main = getLine >>= putStrLn . ans

import Data.List
main :: IO ()
main = do
    inpu <- getLine
    let ns = map read (words inpu)
    putStrLn $ concat $ intersperse " " ( map show (solve ns))
    return ()
solve :: [Int] -> [Int]
solve xs = delete 0 (map f xs)
           where f x =(maximum xs)-x

{-# LANGUAGE BlockArguments #-}

import Control.Arrow
import Data.List

main = do { x <- getLine; putStrLn $ (words >>> map read >>> solve >>> map show >>> unwords) x }

solve :: [Integer] -> [Integer]
solve x = let y = sort x in map (\z -> (last y) - z) (init y)

main = getLine >>= putStrLn . answer . solve . map read . words

answer [] = []
answer (x:xs) = show x ++ " " ++ answer xs

solve xs = filter (/=0) $ map (`subtract` (sum xs `div` 3)) xs

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

import qualified Data.ByteString.Char8 as B
readInt = readLn :: IO Int
readInts = map ( fst . fromJust . B.readInt ) . B.words <$> B.getLine

solve :: [Int] -> [Int]
solve xs = map (uncurry (-)) $ zip (replicate 3 (last ys)) ys
    where ys = sort xs

main :: IO ()
main = do
    xs <- readInts
    putStrLn $ unwords $ map show $ solve xs

import Data.List
main = interact $ unwords . map show . solve . map read . words
solve ns = delete 0 (map (abc -) ns) where
  abc = maximum ns

main =
    getLine >>= \line ->
    let nums = map read $ (words line) :: [Int] in
    let sum_vals = foldl max 0 nums in
    let vals = [sum_vals - x | x <- nums, x /= sum_vals] in
    putStrLn $ unwords $ map show vals

import Data.List
f a = map (\x -> maximum a - x) a
main = interact $ unwords . map show . delete 0 . f . map read . words

import Data.List
import Text.Printf
getList :: IO [Int]
getList = do
    input <- getLine
    let nums = words input
    return $ map read nums

main :: IO()
main = do
    list <- fmap sort getList
    let ans = map (\x -> list!!3-x) (init list)
    putStrLn $ unwords . map show $ ans

module Main where

printSolution :: [Int] -> IO ()
printSolution ints  = sequence_ $ fmap putStr $ fmap (\s -> show s ++ " ") ints

main = do
  let toNumbers line = (map read $ words line) :: [Int]
  row <- fmap toNumbers getLine

  let   solution = filter (/=0) $ map  (\x -> maximum row - x) row
  printSolution solution

{-# LANGUAGE ScopedTypeVariables #-}

main :: IO ()
main = do
  input <- getLine
  let numbers :: [Int] = read <$> words input
  let total = maximum numbers
  let answers = (total -) <$> filter (/= total) numbers
  putStrLn . unwords  $ show <$> answers

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

main= do
		a<- map read <$> words <$> getLine ::IO [Int]
		let m = maximum a
		putStrLn $ intercalate " " $ map  show $ tail $ sort $ map (\z->m-z) a

main = do
  [x1, x2, x3, x4] <- (map read . words) `fmap` getLine :: IO[Integer]
  let allSum = maximum [x1, x2, x3, x4]
  let [a, b, c] = filter (/=0) $ map ((-) allSum) [x1, x2, x3, x4]
  putStrLn $ (show a) ++ " " ++ (show b) ++ " " ++ (show c)

--ghc 7.10

reorder :: (Int,Int,Int,Int) -> (Int,Int,Int,Int)
reorder (x1, x2, x3, x4)
    | x1 + x2 + x3 == 2*x4 = (x1, x2, x3, x4)
    | x1 + x2 + x4 == 2*x3 = (x1, x2, x4, x3)
    | x1 + x3 + x4 == 2*x2 = (x1, x3, x4, x2)
    | x2 + x3 + x4 == 2*x1 = (x2, x3, x4, x1)
    | otherwise = (x1, x2, x3, x4)

restore :: (Int,Int,Int,Int) -> (Int,Int,Int)
restore x = (a,b,c)
    where
        (a'b,b'c,c'a,a'b'c) = reorder x
        c = a'b'c - a'b
        a = a'b'c - b'c
        b = a'b'c - c'a

main = do
    line <- getLine
    let [x1,x2,x3,x4] = map read . words $ line :: [Int]
    let (a,b,c) = restore (x1,x2,x3,x4)
    putStrLn . unwords . map show $ [a,b,c]

{-# OPTIONS_GHC -O2 #-}

import Data.List (sort)

main :: IO ()
main = do
  list@[x, y, z, w] <- fmap (sort . map read . words) getLine :: IO [Int]

  let abc = w
      a   = abc - x
      b   = abc - y
      c   = abc - z

  putStrLn . unwords $ map show [a, b, c]

import Data.List

solve [a, b, c, d] = map show [d - a, d - b, d - c]

main :: IO ()
main = do
    line <- getLine
    let xs = map read $ words line :: [Int]
    putStrLn $ intercalate " " $ solve $ sort xs

import Data.List
main :: IO ()
main = do
    inpu <- getLine
    let ns = map read (words inpu)
    putStrLn $ intersperse ' ' (concat $ map show (solve ns))
    return ()
solve :: [Int] -> [Int]
solve xs = delete 0 (map f xs)
           where f x =(maximum xs)-x

import Data.List
main :: IO ()
main = do
    inpu <- getLine
    let ns = map read (words inpu)
    putStrLn $ intersperse ' ' (concat $ map show (solve ns))
    return ()
solve :: [Int] -> [Int]
solve xs = delete 0 (map f xs)
           where f x =x-(maximum xs)

main =
    getLine >>= \line ->
    let nums = map read $ (words line) :: [Int] in
    let sum_vals = foldl max 0 nums in
    let vals = [sum_vals - x | x <- nums, x /= sum_vals] in
    print $ unwords $ map show vals

import Data.List
f a = map (\x -> x - minimum a) a
main = interact $ show . delete 0 . f . map read . words

import Data.List
f a = map (\x -> x - minimum a) a
main = interact $ unwords . map show . delete 0 . f . map read . words


In Berland the opposition is going to arrange mass walking on the boulevard. The boulevard consists of n tiles that are lain in a row and are numbered from 1 to n from right to left. The opposition should start walking on the tile number 1 and the finish on the tile number n. During the walk it is allowed to move from right to left between adjacent tiles in a row, and jump over a tile. More formally, if you are standing on the tile number i (i < n - 1), you can reach the tiles number i + 1 or the tile number i + 2 from it (if you stand on the tile number n - 1, you can only reach tile number n). We can assume that all the opposition movements occur instantaneously.In order to thwart an opposition rally, the Berland bloody regime organized the rain. The tiles on the boulevard are of poor quality and they are rapidly destroyed in the rain. We know that the i-th tile is destroyed after ai days of rain (on day ai tile isn't destroyed yet, and on day ai + 1 it is already destroyed). Of course, no one is allowed to walk on the destroyed tiles! So the walk of the opposition is considered thwarted, if either the tile number 1 is broken, or the tile number n is broken, or it is impossible to reach the tile number n from the tile number 1 if we can walk on undestroyed tiles.The opposition wants to gather more supporters for their walk. Therefore, the more time they have to pack, the better. Help the opposition to calculate how much time they still have and tell us for how many days the walk from the tile number 1 to the tile number n will be possible.

The first line contains integer n (1 ≤ n ≤ 103) — the boulevard's length in tiles. The second line contains n space-separated integers ai — the number of days after which the i-th tile gets destroyed (1 ≤ ai ≤ 103).

Print a single number — the sought number of days.

NoteIn the first sample the second tile gets destroyed after day three, and the only path left is 1 → 3 → 4. After day five there is a two-tile gap between the first and the last tile, you can't jump over it.In the second sample path 1 → 3 → 5 is available up to day five, inclusive. On day six the last tile is destroyed and the walk is thwarted.

import Control.Applicative

main = do
  _ <- getLine
  a <- map read <$> (words <$> getLine)
  let
    b = a ++ [0]
    c = [0] ++ a
    d = zipWith max b c
  print $ minimum d

module Main where

main = do
    _ <- getLine
    s <- getLine
    let l = (map read (words s)) :: [Int]
    let n = length l
    print(minimum ([max (l !! i) (l !! (i+1)) | i <- [0 .. n-2]] ++ [head l] ++ [last l]))

solve :: [Int] -> Int
solve xs  =  minimum $ [head xs, last xs] ++ pairs
  where
    pairs  =  zipWith max xs (tail xs)

main :: IO ()
main  =  getLine >> getLine >>= return . map read . words >>= print . solve

solve :: Int -> [Int] -> Int
solve n xs | head isNotDestroyed && last isNotDestroyed && longestChain False isNotDestroyed <= 1 = solve (n+1) xs
           | otherwise = n
    where isNotDestroyed = map (>n) xs
longestChain :: (Eq a) => a -> [a] -> Int
longestChain _ [] = 0
longestChain el l@(_:xs) | null a = longestChain el xs
                         | otherwise = max (length a) (longestChain el b)
    where (a, b) = span (==el) l
main = getLine >> fmap (map read . words) getLine >>= print . solve 1

import Data.List
import Data.Ord
import Data.IntSet (IntSet)
import qualified Data.IntSet as IS

main = do
  n <- readLn
  getLine >>= print.solve n.map read.words

solve :: Int -> [Int] -> Int
solve n xs = go (IS.fromList [0,n+1]). sortBy (comparing snd) $ zip [1..] xs
   where
     go set ((i,y):ys)
       | any (`IS.member`set) [i-1,i+1] = y
       | otherwise = go (IS.insert i set) ys

module Main where

main = do
    _ <- getLine
    s <- getLine
    let l = (map read (words s)) :: [Int]
    let n = length l
    print(minimum [max (l !! i) (l !! (i+1)) | i <- [0 .. n-2]])

import Data.List
import Data.Ord
import Data.IntSet (IntSet)
import qualified Data.IntSet as IS

main = getLine >> getLine >>= print.solve.map read.words

solve :: [Int] -> Int
solve [x] = x
solve xs = go IS.empty . sortBy (comparing snd) $ zip [1..] xs
   where
     go set ((i,y):ys)
       | any (`IS.member`set) [i-1,i+1] = y
       | otherwise = go (IS.insert i set) ys


New Year is coming, and Jaehyun decided to read many books during 2015, unlike this year. He has n books numbered by integers from 1 to n. The weight of the i-th (1 ≤ i ≤ n) book is wi.As Jaehyun's house is not large enough to have a bookshelf, he keeps the n books by stacking them vertically. When he wants to read a certain book x, he follows the steps described below.  He lifts all the books above book x.  He pushes book x out of the stack.  He puts down the lifted books without changing their order.  After reading book x, he puts book x on the top of the stack.  He decided to read books for m days. In the j-th (1 ≤ j ≤ m) day, he will read the book that is numbered with integer bj (1 ≤ bj ≤ n). To read the book, he has to use the process described in the paragraph above. It is possible that he decides to re-read the same book several times.After making this plan, he realized that the total weight of books he should lift during m days would be too heavy. So, he decided to change the order of the stacked books before the New Year comes, and minimize the total weight. You may assume that books can be stacked in any possible order. Note that book that he is going to read on certain step isn't considered as lifted on that step. Can you help him?

The first line contains two space-separated integers n (2 ≤ n ≤ 500) and m (1 ≤ m ≤ 1000) — the number of books, and the number of days for which Jaehyun would read books. The second line contains n space-separated integers w1, w2, ..., wn (1 ≤ wi ≤ 100) — the weight of each book. The third line contains m space separated integers b1, b2, ..., bm (1 ≤ bj ≤ n) — the order of books that he would read. Note that he can read the same book more than once.

Print the minimum total weight of books he should lift, which can be achieved by rearranging the order of stacked books.

NoteHere's a picture depicting the example. Each vertical column presents the stacked books.

{-# 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 qualified Data.Foldable as F
import Data.Function
-- import Data.Graph
import Data.Int
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Ratio
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
-- import Data.Tree
import Data.Tuple
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
-- import Debug.Trace
import System.IO

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

main = do
  [n, m] <- getInts
  ws <- getInts
  bs <- getInts

  let
    a = reverse $ foldl (\a b -> if b `elem` a then a else b:a) [] bs

    f _ [] = 0
    f a (b:bs) = c + f a' bs
      where
        c = sum $ map (\i -> ws!!(i-1)) $ takeWhile (/= b) $ a
        a' = b:(a \\ [b])

  print $ f a bs

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

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

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

main = do
    (n,m) <- readIntPair
    ws <- readInts
    bs <- readInts
    print $ solve n m ws bs

solve :: Int -> Int -> [Int] -> [Int] -> Int
solve n m ws bs = calc cs bs where
    cs = go S.empty bs
    go s [] = []
    go s (x:xs) | S.member x s = go s xs
                | otherwise = x:go (S.insert x s) xs
    weight :: UArray Int Int
    weight = listArray (1,n) ws
    calc st [] = 0
    calc st (x:xs) = w + calc st' xs where
        Just i = elemIndex x st
        w = sum $ map (weight !) $ take i st
        st' = x:take i st ++ drop (i+1) st


You are given two integers $$$a$$$ and $$$b$$$. Moreover, you are given a sequence $$$s_0, s_1, \dots, s_{n}$$$. All values in $$$s$$$ are integers $$$1$$$ or $$$-1$$$. It's known that sequence is $$$k$$$-periodic and $$$k$$$ divides $$$n+1$$$. In other words, for each $$$k \leq i \leq n$$$ it's satisfied that $$$s_{i} = s_{i - k}$$$.Find out the non-negative remainder of division of $$$\sum \limits_{i=0}^{n} s_{i} a^{n - i} b^{i}$$$ by $$$10^{9} + 9$$$.Note that the modulo is unusual!

The first line contains four integers $$$n, a, b$$$ and $$$k$$$ $$$(1 \leq n \leq 10^{9}, 1 \leq a, b \leq 10^{9}, 1 \leq k \leq 10^{5})$$$. The second line contains a sequence of length $$$k$$$ consisting of characters '+' and '-'.  If the $$$i$$$-th character (0-indexed) is '+', then $$$s_{i} = 1$$$, otherwise $$$s_{i} = -1$$$. Note that only the first $$$k$$$ members of the sequence are given, the rest can be obtained using the periodicity property.

Output a single integer — value of given expression modulo $$$10^{9} + 9$$$.

import Control.Applicative ((<$>))
import Data.Bits ((.&.))
import Data.Int (Int64)

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let m' = 10^9 + 9 :: Int64
      mod' x = mod x m'
      mpow x p = go (mod' x) 1 1
        where go _ q acc | q > p = acc
              go y q acc = go (mod' $ y*y) (q*2) $ if q .&. p == 0 then acc else mod' (y*acc)

      ainv = mpow a (m' - 2)
      (a1, _) = foldl (\(acc, ab) s -> (mod' (acc + mod' (s*ab)), mod' (mod' (ab*b)*ainv)))
                      (0, mpow a n) ss
      r = mod' (mpow b k * mpow (mpow a k) (m' - 2))
      nk = div (n + 1) k
      gs = if r == 1
           then mod' (a1 * nk)
           else mod' (mod' (a1 * (1 - mpow r nk)) * mpow (1 - r) (m' - 2))

  print gs

import Control.Applicative ((<$>))
import Data.Array (listArray, (!))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- listArray (0, k-1) . map (\x -> if x == '+' then 1 else -1) <$> getLine

  let m' = 10^9 + 9 :: Integer
      m x = rem (x + m') m'
      r = div (b^k) (a^k)
      a1 = foldl (\(acc, (ai, bi)) i ->
                   let acc' = acc + (ss ! i) * ai * bi
                   in  (acc', (div ai a, bi*b)))
                  (0, (a^n, 1)) [0..k-1]

  print . m $
    if a == b
    then fst a1 * div (n + 1) k
    else fst a1 * div (1 - r^(div (n + 1) k)) (1-r)

import Control.Applicative ((<$>))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let mod' x = mod x (10^9 + 9 :: Integer)
      r = (fromInteger b/fromInteger a)^k :: Double
      a1 = fst $ foldl (\(acc, (ai, bi)) s -> (acc + s*ai*bi, (ai `div` a, bi*b)))
                       (0, (a^n, 1)) ss

  print . mod' $
    if a == b
    then mod' a1 * ((n+1) `div` k)
    else round $ fromInteger (mod' a1) * (1 - r^((n+1) `div` k)) / (1-r)

import Control.Applicative ((<$>))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let mod' x = mod x (10^9 + 9 :: Integer)
      r = (fromIntegral b/fromIntegral a) ^ k :: Double
      a1 = fst $ foldl (\(acc, (ai, bi)) s ->
                         let acc' = acc + s*ai*bi
                         in  (mod' acc', (div ai a, bi*b)))
                       (0, (a^n, 1)) ss

  print . mod' . (* a1) $
    if a == b
    then div (n + 1) k
    else round ((1 - r^(div (n+1) k)) / (1-r))

import Control.Applicative ((<$>))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let mod' x = mod x (10^9 + 9 :: Integer)
      r = (fromInteger b/fromInteger a)^k :: Double
      a1 = fst $ foldl (\(acc, (ai, bi)) s -> (mod' (acc + s*ai*bi), (ai `div` a, bi*b)))
                       (0, (a^n, 1)) ss

  print . mod' $
    if a == b
    then a1 * ((n+1) `div` k)
    else round $ fromInteger a1 * (1 - r^((n+1) `div` k)) / (1-r)

import Control.Applicative ((<$>))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let mod' x = mod x (10^9 + 9 :: Integer)
      r = (fromIntegral b/fromIntegral a) ^ k :: Double
      a1 = fst $ foldl (\(acc, (ai, bi)) s ->
                         let acc' = acc + s*ai*bi
                         in  (mod' acc', (div ai a, bi*b)))
                       (0, (a^n, 1)) ss

  print . mod' $
    if a == b
    then a1 * div (n + 1) k
    else round (fromIntegral a1 * (1 - r^(div (n+1) k)) / (1-r))

import Control.Applicative ((<$>))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let mod' x = mod x (10^9 + 9 :: Int)
      r = (b/a)**k :: Double
      a1 = fst $ foldl (\(acc, (ai, bi)) s -> (acc + s*ai*bi, (ai/a, bi*b)))
                       (0, (a**n, 1)) ss

  print . mod' . round $
    if a == b
    then a1 * (n+1) / k
    else a1 * (1 - r**((n+1) / k)) / (1-r)

import Control.Applicative ((<$>))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let m' = 10^9 + 9 :: Int
      r = fromIntegral (mpow b k m') / fromIntegral (mpow a k m')
      a1 = fst $ foldl (\(acc, (ai, bi)) s ->
                         let acc' = acc + s*ai*bi
                         in  (mod acc' m', (div ai a, mod (bi*b) m')))
                       (0, (mpow a n m', 1)) ss

  print . flip mod m' . (* a1) $
    if a == b
    then div (n + 1) k
    else round ((1 - r^(div (n+1) k)) / (1-r))

mpow :: Int -> Int -> Int -> Int
mpow x p m = go p 1
  where go 0 acc = acc
        go p acc = go (p - 1) $ mod (x * acc) m

import Control.Applicative ((<$>))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let mod' x = mod x (10^9 + 9 :: Integer)
      r = (fromIntegral b/fromIntegral a) ^ k :: Double
      a1 = fst $ foldl (\(acc, (ai, bi)) s ->
                         let acc' = acc + s*ai*bi
                         in  (acc', (div ai a, bi*b)))
                       (0, (a^n, 1)) ss

  print . mod' $
    if a == b
    then a1 * div (n + 1) k
    else round (fromIntegral a1 * (1 - r^(div (n+1) k)) / (1-r))

import Control.Applicative ((<$>))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let mod' x = mod x (10^9 + 9 :: Integer)
      r = (b/a)**k :: Double
      a1 = fst $ foldl (\(acc, (ai, bi)) s -> (acc + s*ai*bi, (ai/a, bi*b)))
                       (0, (a**n, 1)) ss

  print . mod' . round $
    if a == b
    then a1 * (n+1) / k
    else a1 * (1 - r**((n+1) / k)) / (1-r)

import Control.Applicative ((<$>))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let mod' x = mod x (10^9 + 9 :: Int)
      r = (fromIntegral b/fromIntegral a) ^ k :: Double
      a1 = fst $ foldl (\(acc, (ai, bi)) s ->
                         let acc' = acc + s*ai*bi
                         in  (mod' acc', (div ai a, bi*b)))
                       (0, (a^n, 1)) ss

  print . mod' $
    if a == b
    then a1 * div (n + 1) k
    else round (fromIntegral a1 * (1 - r^(div (n+1) k)) / (1-r))

import Control.Applicative ((<$>))
import Data.Bits ((.&.))
import Data.Int (Int64)

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let m' = 10^9 + 9 :: Int64
      mod' x = mod x m'
      mpow x p = go (mod' x) 1 1
        where go _ q acc | q > p = acc
              go y q acc = go (mod' $ y*y) (q*2) $ if q .&. p == 0 then acc else mod' (y*acc)

      ainv = mpow a (m' - 2)
      (a1, _, _) = foldl (\(acc, ai, bi) s -> (acc + mod' (s*ai*bi), mod' (ai*ainv), mod' (b*bi)))
                         (0, mpow a n, 1) ss
      r = mod' (mpow b k * mpow (mpow a k) (m' - 2))
      nk = div (n + 1) k
      gs = if r == 1
           then mod' (a1 * nk)
           else mod' (mod' (a1 * (1 - mpow r nk)) * mpow (1 - r) (m' - 2))

  print gs

import Control.Applicative ((<$>))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let mod' x = mod x (10^9 + 9 :: Integer)
      r = fromInteger (b^k)/fromInteger (a^k)
      a1 = fst $ foldl (\(acc, (ai, bi)) s -> (acc + s*ai*bi, (ai `div` a, bi*b)))
                       (0, (a^n, 1)) ss

  print . mod' $
    if a == b
    then a1 * ((n+1) `div` k)
    else round $ fromInteger a1 * (1 - r^((n+1) `div` k)) / (1-r)

import Control.Applicative ((<$>))
import Data.Array (listArray, (!))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- listArray (0, k-1) . map (\x -> if x == '+' then 1 else -1) <$> getLine

  let m' = 10^9 + 9 :: Integer
      m x = rem (m' + rem x m') m'
      r = div (b^k) (a^k)
      a1 = foldl (\(acc, (ai, bi)) i ->
                   let acc' = acc + (ss ! i) * ai * bi
                   in  (m acc', (div ai a, bi*b)))
                  (0, (a^n, 1)) [0..k-1]

  print . m $
    if a == b
    then fst a1 * div (n + 1) k
    else fst a1 * div (1 - r^(div (n + 1) k)) (1-r)

import Control.Applicative ((<$>))
import Data.Array (listArray, (!))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- listArray (0, k-1) . map (\x -> if x == '+' then 1 else -1) <$> getLine

  let m' = 10^9 + 9
      m x = rem (m' + rem x m') m'
      r = div (b^k) (a^k)
      a1 = foldl (\(acc, (ai, bi)) i ->
                   let acc' = acc + (ss ! i) * ai * bi
                   in  (m acc', (div ai a, bi*b)))
                  (0, (a^n, 1)) [0..k-1]

  print . m $
    if a == b
    then fst a1 * div n k
    else fst a1 * div (1 - r^(div n k + 1)) (1-r)

import Control.Applicative ((<$>))
import Data.Array (listArray, (!))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- listArray (0, k - 1) . map (\x -> if x == '+' then 1 else -1) <$> getLine

  let m' = 1000000009
      m x = rem x m'
      loop from to (acc, _) | from > to = acc
      loop from to (acc, (ai, bi)) = loop (from + 1) to (acc', (div ai a, bi * b))
        where s = ss ! from
              acc' = m (m (acc + s*ai*bi) + m')
      a1 = loop 0 (k-1) (0, (a^n, 1))
      r = div (b^k) (a^k)

  print . m $ m' +
    if a == b
    then m (a1 * div n k)
    else  m (a1 * div (1 - r^(div n k + 1)) (1 - r))

import Control.Applicative ((<$>))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let mod' x = mod x (10^9 + 9 :: Integer)
      r = fromInteger (mod' $ b^k) / fromInteger (mod' $ a^k)
      a1 = fst $ foldl (\(acc, (ai, bi)) s ->
                         let acc' = acc + s*ai*bi
                         in  (mod' acc', (div ai a, bi*b)))
                       (0, (a^n, 1)) ss

  print . mod' . (* a1) $
    if a == b
    then div (n + 1) k
    else round ((1 - r^(div (n+1) k)) / (1-r))

import Control.Applicative ((<$>))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let mod' x = mod x (10^9 + 9 :: Integer)
      r = (b**k/a**k):: Double
      a1 = fst $ foldl (\(acc, (ai, bi)) s -> (acc + s*ai*bi, (ai/a, bi*b)))
                       (0, (a**n, 1)) ss

  print . mod' . round $
    if a == b
    then a1 * (n+1) / k
    else a1 * (1 - r**((n+1) / k)) / (1-r)

import Control.Applicative ((<$>))
import Data.Array (listArray, (!))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- listArray (0, k - 1) . map (\x -> if x == '+' then 1 else -1) <$> getLine

  let m' = 1000000009 :: Integer
      m x = rem x m'
      loop from to (acc, _) | from > to = acc
      loop from to (acc, (ai, bi)) = loop (from + 1) to (acc', (div ai a, bi * b))
        where s = ss ! from
              acc' = m (m (acc + s*ai*bi) + m')
      a1 = loop 0 (k-1) (0, (a^n, 1))
      r = div (b^k) (a^k)

  print . m $
    m' + m (a1 * if a == b
                 then div n k
                 else div (1 - r^(div n k + 1)) (1 - r))

import Control.Applicative ((<$>))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let mod' x = mod x (10^9 + 9 :: Integer)
      r = fromInteger (b^k)/fromInteger (a^k)
      a1 = fst $ foldl (\(acc, (ai, bi)) s -> (acc + s*ai*bi, (ai `div` a, bi*b)))
                       (0, (a^n, 1)) ss

  print . mod' $
    if a == b
    then mod' a1 * ((n+1) `div` k)
    else round $ fromInteger (mod' a1) * (1 - r^((n+1) `div` k)) / (1-r)

import Control.Applicative ((<$>))
import Data.Array (listArray, (!))

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- listArray (0, k - 1) . map (\x -> if x == '+' then 1 else -1) <$> getLine

  let m' = 1000000009 :: Integer
      m x = rem x m'
      a1 = fst $ foldl (\(acc, (ai, bi)) i ->
                         (m (m' + m (acc + (ss ! i)*ai*bi)), (div ai a, bi*b)))
                       (0, (a^n, 1)) [0..k-1]
      r = div (b^k) (a^k)

  print . m $
    m' + m (a1 * if a == b
                 then div n k
                 else div (1 - r^(div n k + 1)) (1 - r))

import Control.Applicative ((<$>))
import Data.Bits ((.&.))
import Data.Int (Int64)

main = do
  [n, a, b, k] <- map read . words <$> getLine
  ss <- map (\x -> if x == '+' then 1 else -1) <$> getLine

  let m' = 10^9 + 9 :: Int64
      mod' x = mod x m'
      mpow x p = go (mod' x) 1 1
        where go _ q acc | q > p = acc
              go y q acc = go (mod' $ y*y) (q*2) $ if q .&. p == 0 then acc else mod' (y*acc)

      ainv = mpow a (m' - 2)
      (a1, _, _) = foldl (\(acc, ai, bi) s -> (acc + mod' (s*ai*bi), mod' (ai*ainv), mod' (b*bi)))
                         (0, mpow a n, 1) ss
      r = mod' (mpow b k * mpow (mpow a k) (m' - 2))
      nk = div (n + 1) k
      gs = if a == b
           then mod' (a1 * nk)
           else mod' (mod' (a1 * (1 - mpow r nk)) * mpow (1 - r) (m' - 2))

  print gs


You are given an array $$$a$$$ consisting of $$$n$$$ integer numbers.Let instability of the array be the following value: $$$\max\limits_{i = 1}^{n} a_i - \min\limits_{i = 1}^{n} a_i$$$.You have to remove exactly one element from this array to minimize instability of the resulting $$$(n-1)$$$-elements array. Your task is to calculate the minimum possible instability.

The first line of the input contains one integer $$$n$$$ ($$$2 \le n \le 10^5$$$) — the number of elements in the array $$$a$$$. The second line of the input contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i \le 10^5$$$) — elements of the array $$$a$$$.

Print one integer — the minimum possible instability of the array if you have to remove exactly one element from the array $$$a$$$.

NoteIn the first example you can remove $$$7$$$ then instability of the remaining array will be $$$3 - 1 = 2$$$.In the second example you can remove either $$$1$$$ or $$$100000$$$ then instability of the remaining array will be $$$100000 - 100000 = 0$$$ and $$$1 - 1 = 0$$$ correspondingly.

module Main where

import Control.Applicative
import Control.Monad
import Control.Monad.State
import Data.List
import qualified Data.ByteString.Lazy.Char8 as L

instability :: [Int] -> Int
instability xs = hi - lo
    where hi = maximum xs
          lo = minimum xs

solve :: [Int] -> Int
solve xs = min (instability $ delete hi xs) (instability $ delete lo xs)
    where hi = maximum xs
          lo = minimum xs

tests :: [[Int]]
tests = [[1, 3, 3, 7], [1, 100000]]

type Tokenizer = State [L.ByteString]

nextInt :: Tokenizer Int
nextInt = state $ \(s:ss) -> case L.readInt s of
                               Just (x, _) -> (x, ss)
                               Nothing -> error $ "Can't parse Int from: " ++ (L.unpack s)
go :: Tokenizer Int
go = do
  n <- nextInt
  xs <- replicateM n nextInt
  return $ solve xs

main :: IO ()
main = do
  input <- L.words <$> L.getContents
  let output = evalState go input
  print output

import Data.List

main = do
    s <- getLine
    s <- getLine
    let a = sort (map read (words s)) :: [Int]
    print (min (last a - head (tail a)) (last (init a) - head a))

module Main where

import Data.List (sort, reverse)

getAnswer :: [Int] -> [Int] -> Int
getAnswer (lt : rt : []) _ = 0
getAnswer (lt : lmid : ls) (rt : rmid : rs) = min (rmid - lt) (rt - lmid)

main :: IO ()
main = do
    nStr <- getLine
    let n = read nStr :: Int
    lStr <- getLine
    let l = sort $ map read (words lStr) :: [Int]
    print $ getAnswer l (reverse l)

module Main where
import qualified Data.ByteString.Char8 as C
import Data.List
import Data.Array

main = do
    C.getLine
    as <- map ((read :: String -> Int ). C.unpack ) . C.words <$> C.getLine
    let ass = group $ sort as
        bs = array (1,length ass) $ zip [1..] ass
        r = if head (bs!1) == head (bs!length bs) then 0
             else if length (bs!1) == 1 && length (bs!length bs) == 1 then  min (head (bs!(length bs-1)) - head (bs!1)) (head (bs!length bs) - head (bs!2))
            else if length (bs!1) == 1 && length (bs!length bs) /= 1 then  head (bs!length bs) - head (bs!2)
            else if length (bs!1) /= 1 && length (bs!length bs) == 1 then  head (bs!(length bs-1)) - head (bs!1)
            else head (bs!length bs) - head (bs!1)
    print r

import Data.List
main = interact $ show . solve . map read . words
solve (n:as) = min (c-a) (d-b) where
  s@(a:b:_) = sort as
  [c,d] = drop (n-2) s

import Data.List

main = do
    getLine
    a <- fmap (sort . map read . words) getLine
    print . minimum . map (\x -> last x - head x) $ [init a, tail a]

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

ins m1 = last m1 - head m1

main = do
		n<-read <$> getLine ::IO Int
		m<-sort <$> map read <$> words <$> getLine ::IO [Int]
		let m1 = init m
		let m2 = tail m
		print $ min (ins m1) (ins m2)

import Data.List
main = interact $ show . solve . map read . words
solve (n:as) = min (c-a) (d-b) where
  s@(a:b:_) = sort as
  [c,d] = drop (n-2) as

import Data.List
main = interact $ solve . map read . words
solve (n:as) | n < 100 = show $ min (c-a) (d-b)
             | otherwise = show [a,b,c,d,length as]
 where
  s@(a:b:_) = sort as
  [c,d] = drop (n-2) as


There were n groups of students which came to write a training contest. A group is either one person who can write the contest with anyone else, or two people who want to write the contest in the same team.The coach decided to form teams of exactly three people for this training. Determine the maximum number of teams of three people he can form. It is possible that he can't use all groups to form teams. For groups of two, either both students should write the contest, or both should not. If two students from a group of two will write the contest, they should be in the same team.

The first line contains single integer n (2 ≤ n ≤ 2·105) — the number of groups. The second line contains a sequence of integers a1, a2, ..., an (1 ≤ ai ≤ 2), where ai is the number of people in group i.

Print the maximum number of teams of three people the coach can form.

NoteIn the first example the coach can form one team. For example, he can take students from the first, second and fourth groups.In the second example he can't make a single team.In the third example the coach can form three teams. For example, he can do this in the following way:  The first group (of two people) and the seventh group (of one person),  The second group (of two people) and the sixth group (of one person),  The third group (of two people) and the fourth group (of one person).

module Main where

import Control.Applicative
import Control.Monad

solve :: [Int] -> Int
solve xs = a + b
    where nones = length $ filter (== 1) xs
          ntwos = length xs - nones

          a = min nones ntwos
          b = (nones - a) `div` 3

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

import Data.List
import qualified Data.ByteString.Char8 as B
main = B.interact exec
exec = B.pack . show . solve . map (maybe undefined fst . B.readInt) . tail . B.words
solve = (\gs -> case gs of { [os, ts] -> let lo = length os; lt = length ts in if lo > lt then lt + (lo - lt) `quot` 3 else lo; [os@(1:_)] -> (length os) `quot` 3; _ -> 0}) . group . sort

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

readChar8 :: IO [Int]
readChar8 = map parse . C.words <$> C.getLine
  where parse s = let Just (n, _) = C.readInt s in n

count = foldr (\x (_1s,_2s) -> if x == 1 then (_1s+1,_2s) else (_1s,_2s+1)) (0,0)

main = do
   getLine
   as <- readChar8
   let (a',b') = count as
       r = case (a',b') of
                (a,b) | a==b || b>a -> a
                (a,b) | a>b  -> b + (a-b)`div`3
   print r

import Data.List

f ::[Int]->Int
f xs=let ys=group xs
         (a:b:[])=map length ys
     in if a<=b then a else b+(a-b) `div` 3

main = do
       e<-getLine
       es<-getLine
       let c=read e::Int
           xs=map read (words es)::[Int]
           ys=sort xs
           a=head ys
           b=last ys
       print $ if a==2 then 0 else if b==1 then c `div` 3 else f ys

import Control.Applicative
import Control.Monad

main = sol <$> (getLine *> get) >>= print

get = fmap read . words <$> getLine

--sol :: [Int] -> Int
sol as = p + q
    where
    a1 = length $ filter (==1) as
    a2 = length $ filter (==2) as
    p = min a1 a2
    q = if a1 > a2 then (a1 - a2) `div` 3 else 0

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

main = do
		n<- read<$> getLine ::IO Int
		a<- map read <$> words <$>  getLine::IO [Int]
		let o = length $ filter (==1) a
		let t = length $ filter (==2) a
		let ans = (min o t)
		print $ ans + (div  (o-ans) 3)

{- written by MarekCerny.com -}
{-# LANGUAGE ViewPatterns, PatternSynonyms, CPP,
             TupleSections, UnicodeSyntax, LambdaCase,
             MultiWayIf #-}
import Data.Tuple
import Data.Bits
import Data.Maybe
import Data.Function
import Data.List
import Control.Exception
import qualified Data.HashMap.Strict as M
import Data.Sequence (Seq, (|>), (<|), (><))
import qualified Data.Sequence as S

main = interact $ unlines . sol . allInt . tail . lines

sol :: [[Int]] -> [String]
sol [as] = let
    (j',d') = partition (==1) as
    (j,d) = (length j', length d')
    x = min j d
    x' = (j - x) `div` 3
  in [ show $ (x+x') ]

--------------------------------------------------------------------------------
groupOn :: Int -> [a] -> [[a]]
groupOn _ [] = []
groupOn n xs = let (sts, nds) = splitAt n xs in sts : groupOn n nds

fromBool :: Num a => Bool -> a
fromBool b = if b then 1 else 0

allInt :: [String] -> [[Int]]
allInt = map ((map read) . words)

swrt :: Ord a => (a, a) -> (a, a)
swrt (a, b) | compare b a == LT = (b, a) | otherwise = (a, b)

wrap :: a -> [a]
wrap x = [x]

toSnd :: a->b-> (a,b)
toSnd x y = (x,y)

toFst :: b->a-> (a,b)
toFst y x = (x,y)
--------------------------------------------------------------------------------
pattern Empty   <- (S.viewl -> S.EmptyL)
pattern x :< xs <- (S.viewl -> x S.:< xs)
pattern xs :> x <- (S.viewr -> xs S.:> x)
--------------------------------------------------------------------------------


In a new version of the famous Pinball game, one of the most important parts of the game field is a sequence of n bumpers. The bumpers are numbered with integers from 1 to n from left to right. There are two types of bumpers. They are denoted by the characters '<' and '>'. When the ball hits the bumper at position i it goes one position to the right (to the position i + 1) if the type of this bumper is '>', or one position to the left (to i - 1) if the type of the bumper at position i is '<'. If there is no such position, in other words if i - 1 < 1 or i + 1 > n, the ball falls from the game field.Depending on the ball's starting position, the ball may eventually fall from the game field or it may stay there forever. You are given a string representing the bumpers' types. Calculate the number of positions such that the ball will eventually fall from the game field if it starts at that position.

The first line of the input contains a single integer n (1 ≤ n ≤ 200 000) — the length of the sequence of bumpers. The second line contains the string, which consists of the characters '<' and '>'. The character at the i-th position of this string corresponds to the type of the i-th bumper.

Print one integer — the number of positions in the sequence such that the ball will eventually fall from the game field if it starts at that position.

NoteIn the first sample, the ball will fall from the field if starts at position 1 or position 2.In the second sample, any starting position will result in the ball falling from the field.

import Data.List

main :: IO()
main = print . solve . head . tail . words =<< getContents

removeMaybe :: Int -> Maybe Int -> Int
removeMaybe _ (Just a) = a
removeMaybe n Nothing  = n

solve :: String -> Int
solve s = let n = length s
              l = removeMaybe n $ findIndex (== '>') s
              r = removeMaybe n $ findIndex (== '<') $ reverse s
          in l + r

main = do
	getLine
	x <- getLine
	print $ (length $ takeWhile (== '<') x) + (length $ takeWhile (== '>') $ reverse x)

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

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

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

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

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

  check :: Int -> Int -> Int -> (Int, Bool)
  check k r n =
    let result = (k * n) `mod` 10 == r
        in (n, result)

  solve :: Int -> Int -> [Int]
  solve k r = map fst $ filter snd $ map (check k r) [1..10]

  h :: [Int] -> Int
  h [] = 10
  h (x:xs) = x

  solvex :: Int -> Int
  solvex 5 = 2
  solvex 2 = 5
  solvex 4 = 5
  solvex 6 = 5
  solvex 0 = 1
  solvex 8 = 5
  solvex _ = 10

  r1 :: String -> Int -> Int
  r1 ('<':xs) a = r1 xs (a+1)
  r1 ('>':xs) a = a
  r1 [] a = a

  r2 :: String -> Int -> Int
  r2 ('>':xs) a = r2 xs (a+1)
  r2 ('<':xs) a = a
  r2 [] a = a

  main :: IO()
  main = do
    n <- getLine
    xs <- getLine
    print $ (r1 xs 0) + (r2 (reverse xs) 0)

main=interact$show.f.(!!1).lines
f cs = g cs + h cs
g cs = length $ takeWhile (=='<') cs
h cs = length . takeWhile (=='>') $ reverse cs

import Data.List.Split
main = do
    n <- readLn::IO Int
    str <- getLine
    let (hd:tl) = split (onSublist "><") str
	pre = length $ takeWhile ('<'==) hd
	post = length $ takeWhile ('>'==) . reverse $ last tl
    print $ case hd:tl of
	    [a]	->  length a
	    otherwise ->pre+post

import qualified Data.List as L
main = return ()

import Control.Monad.Trans.State.Lazy
main = do
    n <- readLn::IO Int
    str <- getLine
    let process [] = return 0
	process [b] = return 1
	process (b1:b2:bs)
	  | [b1,b2] == "><" =
		return.length.takeWhile ('>'==)$reverse bs
	  | otherwise	    = modify (b1:) >> process (b2:bs)
    (v,st) <- runStateT (process str) []
    print $ (length $ dropWhile ('>'==) st) + v