Memory is performing a walk on the two-dimensional plane, starting at the origin. He is given a string s with his directions for motion: An 'L' indicates he should move one unit left.  An 'R' indicates he should move one unit right.  A 'U' indicates he should move one unit up.  A 'D' indicates he should move one unit down.But now Memory wants to end at the origin. To do this, he has a special trident. This trident can replace any character in s with any of 'L', 'R', 'U', or 'D'. However, because he doesn't want to wear out the trident, he wants to make the minimum number of edits possible. Please tell Memory what is the minimum number of changes he needs to make to produce a string that, when walked, will end at the origin, or if there is no such string.

The first and only line contains the string s (1 ≤ |s| ≤ 100 000) — the instructions Memory is given.

If there is a string satisfying the conditions, output a single integer — the minimum number of edits required. In case it's not possible to change the sequence in such a way that it will bring Memory to to the origin, output -1.

NoteIn the first sample test, Memory is told to walk right, then right, then up. It is easy to see that it is impossible to edit these instructions to form a valid walk.In the second sample test, Memory is told to walk up, then down, then up, then right. One possible solution is to change s to "LDUR". This string uses 1 edit, which is the minimum possible. It also ends at the origin.

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}

import Control.Applicative
import Control.Monad
import Control.Arrow
import Data.List
import Data.Maybe
import Data.Char
import qualified Data.ByteString.Char8 as B
import Text.Printf

readInt = ( readLn :: IO Int )
readInts = map ( read :: String -> Int ) . words <$> getLine

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

which a b f = if f then a else b
mp [ a, b ] = ( a, b )

main = do
	s <- getLine
	let
		( a, b ) = solve 0 0 s
		d = a + b
	print $ which ( d `div` 2 ) ( -1 ) $ d `mod` 2 == 0

solve a b [] = ( abs a, abs b )
solve a b ( 'L' : s ) = solve ( a - 1 ) b s
solve a b ( 'R' : s ) = solve ( a + 1 ) b s
solve a b ( 'U' : s ) = solve a ( b + 1 ) s
solve a b ( 'D' : s ) = solve a ( b - 1 ) s

main :: IO()
main = do
  str <- getLine
  print $ solve str

solve :: String -> Int
solve str
  | even $ length str = walk str
  | otherwise = -1

walk :: String -> Int
walk str = ((abs x) + (abs y)) `div` 2
  where (x, y) = route str (0, 0)

route :: String -> (Int, Int) -> (Int, Int)
route [] (x1, y1) = (x1, y1)
route (x:xs) (x1, y1)
         | x == 'L' = route xs (x1 - 1, y1)
         | x == 'R' = route xs (x1 + 1, y1)
         | x == 'U' = route xs (x1, y1 + 1)
         | x == 'D' = route xs (x1, y1 - 1)

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

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

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

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

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

  location :: String -> (Int, Int) -> (Int, Int)
  location [] a = a
  location ('U':xs) (x, y) = location xs (x, y + 1)
  location ('D':xs) (x, y) = location xs (x, y - 1)
  location ('L':xs) (x, y) = location xs (x - 1, y)
  location ('R':xs) (x, y) = location xs (x + 1, y)

  location2 :: String -> (Int, Int)
  location2 xs = let
    us = length $ (filter (=='U')) xs
    ds = length $ (filter (=='D')) xs
    ls = length $ (filter (=='L')) xs
    rs = length $ (filter (=='R')) xs
    in ((rs - ls), (us - ds))

  minimumChange :: Int -> Int -> Int
  minimumChange x y
    | odd x = minimumChange (x - 1) (y - 1) + 1
    | otherwise = abs (x `div` 2) + abs (y `div` 2)

  solve :: String -> Int
  solve xs
    | length xs `mod` 2 == 1 = -1
    | otherwise =
      let (x, y) = location xs (0, 0)
          in minimumChange (abs x) (abs y)

  sameLoc :: (Int, Int) -> (Int, Int) -> Bool
  sameLoc (x, y) (p, q)
    | x == p && y == q = True

  main :: IO()
  main = do
    xs <- getLine
    putStrLn $ show $ solve xs

solve s | (length s) `mod` 2 == 1  = -1
        | otherwise                = ans
        where
            us = length $ filter (\x -> x == 'U') s
            ds = length $ filter (\x -> x == 'D') s
            r1 = (abs (us - ds)) `mod` 2
            ls = length $ filter (\x -> x == 'L') s
            rs = length $ filter (\x -> x == 'R') s
            r2 = (abs (ls - rs)) `mod` 2
            ans = ((abs (us - ds)) `div` 2) + ((abs (ls - rs)) `div` 2) + ((r1 + r2) `div` 2)

main = do
    s <- getLine
    print $ solve s

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

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

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

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

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

  location :: String -> (Int, Int) -> (Int, Int)
  location [] a = a
  location ('U':xs) (x, y) = location xs (x, y + 1)
  location ('D':xs) (x, y) = location xs (x, y - 1)
  location ('L':xs) (x, y) = location xs (x - 1, y)
  location ('R':xs) (x, y) = location xs (x + 1, y)

  minimumChange :: Int -> Int -> Int
  minimumChange x y
    | odd x = minimumChange (x - 1) (y - 1) + 1
    | otherwise = (x `div` 2) + (y `div` 2)

  solve :: String -> Int
  solve xs
    | length xs `mod` 2 == 1 = -1
    | otherwise =
      let (x, y) = location xs (0, 0)
          in minimumChange x y

  main :: IO()
  main = do
    xs <- getLine
    putStrLn $ show $ solve xs

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

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

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

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

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

  location :: String -> (Int, Int) -> (Int, Int)
  location [] a = a
  location ('U':xs) (x, y) = location xs (x, y + 1)
  location ('D':xs) (x, y) = location xs (x, y - 1)
  location ('L':xs) (x, y) = location xs (x - 1, y)
  location ('R':xs) (x, y) = location xs (x + 1, y)

  location2 :: String -> (Int, Int)
  location2 xs = let
    us = length $ (filter (=='U')) xs
    ds = length $ (filter (=='D')) xs
    ls = length $ (filter (=='L')) xs
    rs = length $ (filter (=='R')) xs
    in ((rs - ls), (us - ds))

  minimumChange :: Int -> Int -> Int
  minimumChange x y
    | odd x = minimumChange (x - 1) (y - 1) + 1
    | otherwise = abs (x `div` 2) + abs (y `div` 2)

  solve :: String -> Int
  solve xs
    | length xs `mod` 2 == 1 = -1
    | otherwise =
      let (x, y) = location xs (0, 0)
          in minimumChange (abs x) (abs y)

  sameLoc :: (Int, Int) -> (Int, Int) -> Bool
  sameLoc (x, y) (p, q)
    | x == p && y == q = True

  main :: IO()
  main = do
    xs <- getLine
    let l1 = location xs (0, 0)
        l2 = location2 xs
        s = sameLoc l1 l2
    putStrLn $ show l1
    putStrLn $ show s
    putStrLn $ show $ solve xs


You are given a $$$1$$$ by $$$n$$$ pixel image. The $$$i$$$-th pixel of the image has color $$$a_i$$$. For each color, the number of pixels of that color is at most $$$20$$$.You can perform the following operation, which works like the bucket tool in paint programs, on this image:   pick a color — an integer from $$$1$$$ to $$$n$$$;  choose a pixel in the image;  for all pixels connected to the selected pixel, change their colors to the selected color (two pixels of the same color are considered connected if all the pixels between them have the same color as those two pixels). Compute the minimum number of operations needed to make all the pixels in the image have the same color.

Each test contains multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \le t \le 10^3$$$). The first line of each test case contains a single integer $$$n$$$ ($$$1 \le n \le 3\cdot10^3$$$) — the number of pixels in the image. The second line of each test case contains $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$ ($$$1 \le a_i \le n$$$) — the colors of the pixels in the image. Note: for each color, the number of pixels of that color is at most $$$20$$$. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$3\cdot10^3$$$.

For each test case, print one integer: the minimum number of operations needed to make all the pixels in the image have the same color.

NoteIn the first example, the optimal solution is to apply the operation on the third pixel changing its color to $$$2$$$ and then to apply the operation on any pixel that has color $$$2$$$ changing its color and the color of all pixels connected to it to $$$1$$$. The sequence of operations is then: $$$[1, 2, 3, 2, 1] \to [1, 2, 2, 2, 1] \to [1, 1, 1, 1, 1]$$$.In the second example, we can either change the $$$1$$$s to $$$2$$$s in one operation or change the $$$2$$$s to $$$1$$$s also in one operation.In the third example, one possible way to make all the pixels have the same color is to apply the operation on the first, third and the fourth pixel each time changing its color to $$$2$$$.

import qualified Data.ByteString.Lazy.Char8 as P
import Data.ByteString.Builder
import qualified Data.ByteString.Builder.Prim as Prim
import System.IO
import Control.Monad.Trans.State

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

-- This might be a bit too slow as-is, unfortunately.
solve :: [Int] -> Int
solve aLi = let
  aLiDedup = map head $ group aLi
  n = length aLiDedup
  a :: UArray Int Int
  a = listArray (1, n) aLiDedup
  ixs :: Array Int [Int]
  ixs = accumArray (flip (:)) []
    (foldl' min maxBound $ elems a,
     foldl' max minBound $ elems a)
    [(aii, ii) | (ii, aii) <- assocs a]
  in  (! (1, n)) $ runSTUArray $ do
  ans <- newArray ((1, 1), (n, n)) 0
  forM_ [2 .. n] $ \len ->
    forM_ [1 .. n - len + 1] $ \ii -> let
      jj = ii + len - 1
      splitPts = filter (inRange (ii + 2, jj)) $ ixs ! (a ! ii)
      in  do
      rawCost <- (1 +) <$> readArray ans (ii + 1, jj)
      cost <- (\fun -> foldM fun rawCost splitPts) $ \prevCost splitPt -> do
        beforeSplit <- readArray ans (ii + 1, splitPt - 1)
        afterSplit <- readArray ans (splitPt, jj)
        pure $ min prevCost $ 1 + beforeSplit + afterSplit
      writeArray ans (ii, jj) cost
  pure ans

mainFun :: SO
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    a <- getInts n
    pure $ putInts [solve a]

type SP = State [P.ByteString]
type SO = SP Builder

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

getInts :: Int -> SP [Int]
getInts k = do
  vs <- getNext k
  pure [v | Just (v, _) <- map P.readInt vs]

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

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


It is now 125 years later, but humanity is still on the run from a humanoid-cyborg race determined to destroy it. Or perhaps we are getting some stories mixed up here... In any case, the fleet is now smaller. However, in a recent upgrade, all the navigation systems have been outfitted with higher-dimensional, linear-algebraic jump processors.Now, in order to make a jump, a ship's captain needs to specify a subspace of the d-dimensional space in which the events are taking place. She does so by providing a generating set of vectors for that subspace.Princess Heidi has received such a set from the captain of each of m ships. Again, she would like to group up those ships whose hyperspace jump subspaces are equal. To do so, she wants to assign a group number between 1 and m to each of the ships, so that two ships have the same group number if and only if their corresponding subspaces are equal (even though they might be given using different sets of vectors).Help Heidi!

The first line of the input contains two space-separated integers m and d (2 ≤ m ≤ 30 000, 1 ≤ d ≤ 5) – the number of ships and the dimension of the full underlying vector space, respectively. Next, the m subspaces are described, one after another. The i-th subspace, which corresponds to the i-th ship, is described as follows: The first line contains one integer ki (1 ≤ ki ≤ d). Then ki lines follow, the j-th of them describing the j-th vector sent by the i-th ship. Each of the j lines consists of d space-separated integers aj, j = 1, ..., d, that describe the vector ; it holds that |aj| ≤ 250. The i-th subspace is the linear span of these ki vectors.

Output m space-separated integers g1, ..., gm, where  denotes the group number assigned to the i-th ship. That is, for any 1 ≤ i < j ≤ m, the following should hold: gi = gj if and only if the i-th and the j-th subspaces are equal. In addition, the sequence (g1, g2, ..., gm) should be lexicographically minimal among all sequences with that property.

NoteIn the sample testcase, the first and the last subspace are equal, subspaces 2 to 4 are equal, and subspaces 5 to 7 are equal.Recall that two subspaces, one given as the span of vectors  and another given as the span of vectors , are equal if each vector vi can be written as a linear combination of vectors w1, ..., wk (that is, there exist coefficients  such that vi = α1w1 + ... + αkwk) and, similarly, each vector wi can be written as a linear combination of vectors v1, ..., vn.Recall that a sequence (g1, g2, ..., gm) is lexicographically smaller than a sequence (h1, h2, ..., hm) if there exists an index i, 1 ≤ i ≤ m, such that gi < hi and gj = hj for all j < i.

{-# LANGUAGE TupleSections, BangPatterns #-}

module Main where

import Data.Array
import Data.Array.ST.Safe
import Control.Monad
import Control.Applicative
import qualified Data.HashMap.Strict as M
import Control.Monad.State.Strict
import Data.Foldable(toList)
import System.Random
import Data.List.Split(chunksOf)
import Data.List

rref :: Integral a => [[a]] -> Array (Int,Int) Rational
rref xs = runSTArray $ do
  mat <- newListArray ((1,1), (d,d)) (fmap fromIntegral $ concat xs)
  go mat 1 1
  return mat
  where
    d = length xs
    go mat h k = when (h <= d && k <= d) $ do
      i_max <- maxIndex mat k [h..d]
      v_max <- readArray mat (i_max,k)
      if v_max == 0
      then go mat h (k+1)
      else do
        swapRows mat h i_max
        normalizeRow mat h v_max
        forM_ (filter (/=h) [1..d]) $ \i -> do
          f <- liftA2 (/) (readArray mat (i,k)) (readArray mat (h,k))
          writeArray mat (i,k) 0
          forM_ [k+1..d] $ \j -> do
            t <- liftA2 (-) (readArray mat (i,j)) (fmap (*f) $ readArray mat (h,j))
            writeArray mat (i,j) t
        go mat (h+1) (k+1)

    normalizeRow mat h x = forM_ [1..d] $ \i -> do
      y <- readArray mat (h,i)
      writeArray mat (h,i) (y / x)

    swapRows mat i j = do
      let allCols = [1..d]
      xis <- mapM (readArray mat . (i,)) allCols
      xjs <- mapM (readArray mat . (j,)) allCols
      sequence_ $ zipWith (\k x -> writeArray mat (i,k) x) allCols xjs
      sequence_ $ zipWith (\k x -> writeArray mat (j,k) x) allCols xis

    maxIndex mat k (i : is) = do
      x_i <- readArray mat (i, k)
      go i (abs x_i) is
      where
        go max_i max_val [] = return max_i
        go max_i max_val (j:js) = do
          x_j <- readArray mat (j,k)
          if abs x_j > max_val
          then go j (abs x_j) js
          else go max_i max_val js

solve xs =
  flip evalState (1,M.empty)
  . mapM groupArray
  . fmap toList
  . fmap rref
  $ fmap (padZeroes (length $ head $ head xs)) xs

groupArray :: [Rational] -> State (Int, M.HashMap [Rational] Int) Int
groupArray arr = do
  (!i, m) <- get
  case M.lookup arr m of
    Nothing -> do
      put (i+1, M.insert arr i m)
      return i
    Just n -> return n

padZeroes d xs = go d xs where
  go 0 _ = []
  go n [] = zeroVec : go (n-1) []
  go n (x:xs) = x : go (n-1) xs
  zeroVec = replicate d 0

parseInput xs = parseVecs rest
  where
    ([n,d]:rest) =  fmap (fmap read . words) $ lines xs :: [[Int]]
    parseVecs [] = []
    parseVecs ([m]:ms) = sp : parseVecs sps where
      (sp, sps) = splitAt m ms

main :: IO ()
main = do
  input <- getContents
  putStrLn . intercalate " " . fmap show . solve . parseInput $ input


You are given a permutation $$$p$$$ of integers from $$$0$$$ to $$$n-1$$$ (each of them occurs exactly once). Initially, the permutation is not sorted (that is, $$$p_i>p_{i+1}$$$ for at least one $$$1 \le i \le n - 1$$$). The permutation is called $$$X$$$-sortable for some non-negative integer $$$X$$$ if it is possible to sort the permutation by performing the operation below some finite number of times:   Choose two indices $$$i$$$ and $$$j$$$ $$$(1 \le i \lt j \le n)$$$ such that $$$p_i \& p_j = X$$$.  Swap $$$p_i$$$ and $$$p_j$$$. Here $$$\&$$$ denotes the bitwise AND operation.Find the maximum value of $$$X$$$ such that $$$p$$$ is $$$X$$$-sortable. It can be shown that there always exists some value of $$$X$$$ such that $$$p$$$ is $$$X$$$-sortable.

The input consists of multiple test cases. The first line contains a single integer $$$t$$$ $$$(1 \le t \le 10^4)$$$  — the number of test cases. Description of test cases follows. The first line of each test case contains a single integer $$$n$$$ $$$(2 \le n \le 2 \cdot 10^5)$$$  — the length of the permutation. The second line of each test case contains $$$n$$$ integers $$$p_1, p_2, ..., p_n$$$ ($$$0 \le p_i \le n-1$$$, all $$$p_i$$$ are distinct)  — the elements of $$$p$$$. It is guaranteed that $$$p$$$ is not sorted. It is guaranteed that the sum of $$$n$$$ over all cases does not exceed $$$2 \cdot 10^5$$$.

For each test case output a single integer — the maximum value of $$$X$$$ such that $$$p$$$ is $$$X$$$-sortable.

-- https://codeforces.com/contest/1679/problem/D
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TupleSections #-}

import Control.Arrow ((>>>))
import Control.Monad (
    MonadPlus (mplus),
    foldM_,
    forM_,
    guard,
    join,
    replicateM,
    replicateM_,
 )
import qualified Control.Monad.ST.Strict as ST
import qualified Control.Monad.State.Strict as S

import qualified Data.Array as A
import qualified Data.Array.MArray.Safe as MA
import qualified Data.Array.ST.Safe as STA
import qualified Data.Array.Unboxed as UA

import Data.Bits
import qualified Data.ByteString.Char8 as B8
import Data.Char
import Data.Int

import Data.Function (on)
import Data.Functor ((<&>))
import Data.Maybe (fromJust, fromMaybe, isJust)

import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.List   as L
import Data.List (
    elemIndices,
    find,
    findIndices,
    intersect,
    isPrefixOf,
    nub,
    sort,
    sortOn,
 )
import qualified Data.Map as M
import qualified Data.Set as S

import Control.Monad.Cont (MonadIO (liftIO))
import Data.IORef (modifyIORef, newIORef, readIORef)
import GHC.IO.Handle (hDuplicateTo)
import System.IO (
    IOMode (ReadMode, WriteMode),
    openFile,
    stdin,
    stdout,
 )
import System.Posix.Internals (puts)
import Text.Printf (printf)

-- import Debug.Trace (trace, traceM, traceShowM)
-- debug = flip trace

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

readIntB8s :: B8.ByteString -> [Int]
readIntB8s = B8.words >>> map (B8.readInt >>> (fst . fromJust))

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

readIntegerB8s :: B8.ByteString -> [Integer]
readIntegerB8s = B8.words >>> map (B8.readInteger >>> (fst . fromJust))

modifyArray :: (MA.MArray a e m, MA.Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray arr ix f = do
    value <- MA.readArray arr ix
    MA.writeArray arr ix $ f value

putsYesNo :: Bool -> IO ()
putsYesNo value = do
    let result :: String =
            if value
                then "Yes"
                else "No"
    printf "%s\n" result

{- END OF GENERAL -}

solve :: Int -> [Int] -> Int
solve n ps = L.foldr1 (.&.) notInPlacePs
    where
        notInPlacePs = L.map fst . L.filter (uncurry (/=)) . L.zip [0 ..] $ ps

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        n <- B8.getLine <&> readIntB8
        ps <- B8.getLine <&> readIntB8s
        let answer = solve n ps
        printf "%d\n" answer


Kuroni has $$$n$$$ daughters. As gifts for them, he bought $$$n$$$ necklaces and $$$n$$$ bracelets:  the $$$i$$$-th necklace has a brightness $$$a_i$$$, where all the $$$a_i$$$ are pairwise distinct (i.e. all $$$a_i$$$ are different),  the $$$i$$$-th bracelet has a brightness $$$b_i$$$, where all the $$$b_i$$$ are pairwise distinct (i.e. all $$$b_i$$$ are different). Kuroni wants to give exactly one necklace and exactly one bracelet to each of his daughters. To make sure that all of them look unique, the total brightnesses of the gifts given to each daughter should be pairwise distinct. Formally, if the $$$i$$$-th daughter receives a necklace with brightness $$$x_i$$$ and a bracelet with brightness $$$y_i$$$, then the sums $$$x_i + y_i$$$ should be pairwise distinct. Help Kuroni to distribute the gifts.For example, if the brightnesses are $$$a = [1, 7, 5]$$$ and $$$b = [6, 1, 2]$$$, then we may distribute the gifts as follows:  Give the third necklace and the first bracelet to the first daughter, for a total brightness of $$$a_3 + b_1 = 11$$$. Give the first necklace and the third bracelet to the second daughter, for a total brightness of $$$a_1 + b_3 = 3$$$. Give the second necklace and the second bracelet to the third daughter, for a total brightness of $$$a_2 + b_2 = 8$$$. Here is an example of an invalid distribution:   Give the first necklace and the first bracelet to the first daughter, for a total brightness of $$$a_1 + b_1 = 7$$$. Give the second necklace and the second bracelet to the second daughter, for a total brightness of $$$a_2 + b_2 = 8$$$. Give the third necklace and the third bracelet to the third daughter, for a total brightness of $$$a_3 + b_3 = 7$$$. This distribution is invalid, as the total brightnesses of the gifts received by the first and the third daughter are the same. Don't make them this upset!

The input consists of multiple test cases. The first line contains an integer $$$t$$$ ($$$1 \le t \le 100$$$)  — the number of test cases. The description of the test cases follows. The first line of each test case contains a single integer $$$n$$$ ($$$1 \le n \le 100$$$)  — the number of daughters, necklaces and bracelets. The second line of each test case contains $$$n$$$ distinct integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i \le 1000$$$)  — the brightnesses of the necklaces. The third line of each test case contains $$$n$$$ distinct integers $$$b_1, b_2, \dots, b_n$$$ ($$$1 \le b_i \le 1000$$$)  — the brightnesses of the bracelets.

For each test case, print a line containing $$$n$$$ integers $$$x_1, x_2, \dots, x_n$$$, representing that the $$$i$$$-th daughter receives a necklace with brightness $$$x_i$$$. In the next line print $$$n$$$ integers $$$y_1, y_2, \dots, y_n$$$, representing that the $$$i$$$-th daughter receives a bracelet with brightness $$$y_i$$$. The sums $$$x_1 + y_1, x_2 + y_2, \dots, x_n + y_n$$$ should all be distinct. The numbers $$$x_1, \dots, x_n$$$ should be equal to the numbers $$$a_1, \dots, a_n$$$ in some order, and the numbers $$$y_1, \dots, y_n$$$ should be equal to the numbers $$$b_1, \dots, b_n$$$ in some order.  It can be shown that an answer always exists. If there are multiple possible answers, you may print any of them.

NoteIn the first test case, it is enough to give the $$$i$$$-th necklace and the $$$i$$$-th bracelet to the $$$i$$$-th daughter. The corresponding sums are $$$1 + 8 = 9$$$, $$$8 + 4 = 12$$$, and $$$5 + 5 = 10$$$.The second test case is described in the statement.

import Control.Monad
import Data.List

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

routine :: IO ()
routine = do
  _ <- getLine
  as <- (map read.words) <$> getLine
  bs <- (map read.words) <$> getLine
  putStrLn $ (unwords.map show) $ sort (as:: [Int])
  putStrLn $ (unwords.map show) $ sort (bs :: [Int])

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

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

type EIO a = ExceptT String IO a

data HNormal
data HString
data HList

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

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

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

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

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

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

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

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

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

main_ :: EIO ()
-- template --
main_ = do
    t <- get
    replicateM_ t f1

f1 :: EIO ()
f1 = do
    n <- get
    a <- replicateM n get
    b <- replicateM n get
    let (x, y) = f2 n a b in do
        putln x
        putln y

f2 :: Int -> [Int] -> [Int] -> ([Int], [Int])
f2 n a b = (sort a, sort b)

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

onecase = do
		getLine
		a<- sort <$> map read <$> words <$> getLine ::IO [Int]
		b<- sort <$> map read <$> words <$> getLine ::IO [Int]
		putStrLn $ intercalate " " $ map show a
		putStrLn $ intercalate " " $ map show b

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

import Data.List (sort)

process :: ([Int],[Int]) -> ([Int],[Int])
process (as,bs) = (sort as, sort bs)

readInt :: String -> Int
readInt = read

run :: Int -> IO ()
run 0 = return ()
run t = do
    n <- fmap readInt getLine
    as <- fmap (map readInt.words) getLine
    bs <- fmap (map readInt.words) getLine
    let (xs, ys) = process (as,bs)
    putStrLn . unwords . map show $ xs
    putStrLn . unwords . map show $ ys
    run (t-1)

main :: IO ()
main = do
    t <- fmap readInt getLine
    run t

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

onecase = do
		getLine
		a<- sort <$> map read <$> words <$> getLine ::IO [Int]
		b<- sort <$> map read <$> words <$> getLine ::IO [Int]
		print $ intercalate " " $ map show a
		print $ intercalate " " $ map show b

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


You are given a sequence $$$s$$$ consisting of $$$n$$$ digits from $$$1$$$ to $$$9$$$.You have to divide it into at least two segments (segment — is a consecutive sequence of elements) (in other words, you have to place separators between some digits of the sequence) in such a way that each element belongs to exactly one segment and if the resulting division will be represented as an integer numbers sequence then each next element of this sequence will be strictly greater than the previous one.More formally: if the resulting division of the sequence is $$$t_1, t_2, \dots, t_k$$$, where $$$k$$$ is the number of element in a division, then for each $$$i$$$ from $$$1$$$ to $$$k-1$$$ the condition $$$t_{i} < t_{i + 1}$$$ (using numerical comparing, it means that the integer representations of strings are compared) should be satisfied.For example, if $$$s=654$$$ then you can divide it into parts $$$[6, 54]$$$ and it will be suitable division. But if you will divide it into parts $$$[65, 4]$$$ then it will be bad division because $$$65 > 4$$$. If $$$s=123$$$ then you can divide it into parts $$$[1, 23]$$$, $$$[1, 2, 3]$$$ but not into parts $$$[12, 3]$$$.Your task is to find any suitable division for each of the $$$q$$$ independent queries.

The first line of the input contains one integer $$$q$$$ ($$$1 \le q \le 300$$$) — the number of queries. The first line of the $$$i$$$-th query contains one integer number $$$n_i$$$ ($$$2 \le n_i \le 300$$$) — the number of digits in the $$$i$$$-th query. The second line of the $$$i$$$-th query contains one string $$$s_i$$$ of length $$$n_i$$$ consisting only of digits from $$$1$$$ to $$$9$$$.

If the sequence of digits in the $$$i$$$-th query cannot be divided into at least two parts in a way described in the problem statement, print the single line "NO" for this query. Otherwise in the first line of the answer to this query print "YES", on the second line print $$$k_i$$$ — the number of parts in your division of the $$$i$$$-th query sequence and in the third line print $$$k_i$$$ strings $$$t_{i, 1}, t_{i, 2}, \dots, t_{i, k_i}$$$ — your division. Parts should be printed in order of the initial string digits. It means that if you write the parts one after another without changing their order then you'll get the string $$$s_i$$$. See examples for better understanding.

import qualified Data.ByteString.Char8 as B
import Control.Arrow
import Data.Maybe
import Data.Char
import Data.Foldable

ilen a = snd $ until ((==0) . fst) ((`div`10)***(+1)) (a,0)

int = fst . fromJust . B.readInt

getNext :: Integer -> Integer -> B.ByteString -> (Integer, B.ByteString)
getNext z x y =
    case B.uncons y of
        Nothing -> (z,B.empty)
        Just (a,b) ->
            let n = z*10 + (toInteger $ digitToInt a)
            in if n > x
                then (n,b)
                else getNext n x b

solve :: Integer -> B.ByteString -> [String] -> Integer -> String
solve a x s n =
    let (p,q) = getNext 0 a x
    in if q == B.empty
         then let s' = unwords $ reverse s in
            if a >= p
                then if n > 2 then "YES\n" ++ show (n-1) ++ "\n" ++ s' ++ show p else "NO"
                else if n > 1 then "YES\n" ++ show n ++ "\n" ++ s' ++ " " ++  show p else "NO"
         else solve p q ( show p : s) (n+1)

main = do
    n <- readLn :: IO Int
    for_ [1..n] $ \_ -> do
        getLine
        s <- B.getLine
        putStrLn $ solve (0::Integer) (B.filter isDigit s)  [] 1

import qualified Data.ByteString.Char8 as B
import Control.Arrow
import Data.Maybe
import Data.Char
import Data.Foldable

ilen a = snd $ until ((==0) . fst) ((`div`10)***(+1)) (a,0)

int = fst . fromJust . B.readInt

getNext z x y =
    case B.uncons y of
        Nothing -> (z,B.empty)
        Just (a,b) ->
            let n = z*10 + digitToInt a
            in if n > x
                then (n,b)
                else getNext n x b

solve a x s n =
    let (p,q) = getNext 0 a x
    in if q == B.empty
         then let s' = unwords $ reverse s in
            if a >= p
                then if n > 2 then "YES\n" ++ show (n-1) ++ "\n" ++ s' ++ show p else "NO"
                else if n > 1 then "YES\n" ++ show n ++ "\n" ++ s' ++ " " ++  show p else "NO"
         else solve p q ( show p : s) (n+1)

main = do
    n <- readLn :: IO Int
    for_ [1..n] $ \_ -> do
        getLine
        s <- B.getLine
        putStrLn $ solve 0 (B.filter isDigit s)  [] 1

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}

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

ilen a = snd $ until ((==0) . fst) ((`div`10)***(+1)) (a,0)

int = fst . fromJust . B.readInt

solve x =
    let h = digitToInt $  B.head x
        ls' = h : unfoldr (\(x,y) -> if y == B.empty
                                    then Nothing
                                    else let z = dropWhile ( (x>=) . fst  ) $ map ((int *** id ) . (flip B.splitAt $ y)) [1..B.length y-1]
                                         in if null z
                                            then Just (int y, (int y, B.empty))
                                            else let z'@(za,_) = head z in Just (za,z')) (h, B.tail x)
        ls = if length ls' > 1
            then let (a,b) =  (ls' !! (length ls' - 2), last ls')
                 in if a >= b
                        then (init $ init ls') ++ [(a*10^(ilen b)) + b]
                        else ls'
            else [1]
    in B.pack $ (if | length ls > 1 -> "YES\n" ++ (unwords $ map show ls) | True ->  "NO")

main = B.interact $ B.unlines . map solve . fix (\f -> \case {[]->[]; (_:a:as)-> B.filter isDigit a : f as}) . tail . B.lines


You are given a string $$$s$$$, consisting only of characters '0' or '1'. Let $$$|s|$$$ be the length of $$$s$$$.You are asked to choose some integer $$$k$$$ ($$$k > 0$$$) and find a sequence $$$a$$$ of length $$$k$$$ such that:   $$$1 \le a_1 < a_2 < \dots < a_k \le |s|$$$;  $$$a_{i-1} + 1 < a_i$$$ for all $$$i$$$ from $$$2$$$ to $$$k$$$. The characters at positions $$$a_1, a_2, \dots, a_k$$$ are removed, the remaining characters are concatenated without changing the order. So, in other words, the positions in the sequence $$$a$$$ should not be adjacent.Let the resulting string be $$$s'$$$. $$$s'$$$ is called sorted if for all $$$i$$$ from $$$2$$$ to $$$|s'|$$$ $$$s'_{i-1} \le s'_i$$$.Does there exist such a sequence $$$a$$$ that the resulting string $$$s'$$$ is sorted?

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 1000$$$) — the number of testcases. Then the descriptions of $$$t$$$ testcases follow. The only line of each testcase contains a string $$$s$$$ ($$$2 \le |s| \le 100$$$). Each character is either '0' or '1'.

For each testcase print "YES" if there exists a sequence $$$a$$$ such that removing the characters at positions $$$a_1, a_2, \dots, a_k$$$ and concatenating the parts without changing the order produces a sorted string. Otherwise, print "NO". You may print every letter in any case you want (so, for example, the strings yEs, yes, Yes and YES are all recognized as positive answer).

NoteIn the first testcase you can choose a sequence $$$a=[1,3,6,9]$$$. Removing the underlined letters from "10101011011" will produce a string "0011111", which is sorted.In the second and the third testcases the sequences are already sorted.In the fourth testcase you can choose a sequence $$$a=[3]$$$. $$$s'=$$$ "11", which is sorted.In the fifth testcase there is no way to choose a sequence $$$a$$$ such that $$$s'$$$ is sorted.

import Control.Monad
import Data.List

solve2 [x] = False
solve2 (x:y:xs)
            | x == '0' && y == '0' = True
            | otherwise = solve2 (y:xs)

solve [x,y] = False
solve (x:y:xs)
            | x == '1' && y == '1' = solve2 xs
            | otherwise = solve (y:xs)

printResult xs = putStrLn r where r = if solve xs then "NO" else "YES"

main = do
    t <- readLn :: IO Int
    xss <- replicateM t getLine
    mapM printResult xss

import Control.Monad
import Data.List
solve xs = putStrLn r where r = if isInfixOf "1100" xs then "NO" else "YES"
main = do
    t <- readLn :: IO Int
    xss <- replicateM t getLine
    mapM solve xss


Find out if it is possible to partition the first $$$n$$$ positive integers into two non-empty disjoint sets $$$S_1$$$ and $$$S_2$$$ such that:$$$\mathrm{gcd}(\mathrm{sum}(S_1), \mathrm{sum}(S_2)) > 1$$$ Here $$$\mathrm{sum}(S)$$$ denotes the sum of all elements present in set $$$S$$$ and $$$\mathrm{gcd}$$$ means thegreatest common divisor.Every integer number from $$$1$$$ to $$$n$$$ should be present in exactly one of $$$S_1$$$ or $$$S_2$$$.

The only line of the input contains a single integer $$$n$$$ ($$$1 \le n \le 45\,000$$$)

If such partition doesn't exist, print "No" (quotes for clarity). Otherwise, print "Yes" (quotes for clarity), followed by two lines, describing $$$S_1$$$ and $$$S_2$$$ respectively. Each set description starts with the set size, followed by the elements of the set in any order. Each set must be non-empty. If there are multiple possible partitions — print any of them.

NoteIn the first example, there is no way to partition a single number into two non-empty sets, hence the answer is "No".In the second example, the sums of the sets are $$$2$$$ and $$$4$$$ respectively. The $$$\mathrm{gcd}(2, 4) = 2 > 1$$$, hence that is one of the possible answers.

import Data.List

main = do
  n <- readLn :: IO Int

  case solve n of
    Nothing -> putStrLn "No"
    Just x -> do
      putStrLn "Yes"
      putStrLn $ unwords . map show $ [1,x]
      putStrLn $ unwords . map show $ (n-1):(delete x [1..n])

solve 1 = Nothing
solve n = find (\x -> gcd (s-x) x > 1) [1..n]
  where
    s = n*(n+1)`div`2

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

main = sol <$> readLn >>= mapM_ putStrLn

sol n = if n > 2
    then ["Yes", put s1, put s2]
    else ["No"]
    where
    s1 = 1:[n]
    s2 = (n-1):[1..n-1]

put = unwords . fmap show

module Main where
import Data.Maybe

default (Int)
main = interact $ maybe "No" (\(xs, ys) -> unlines ["Yes", unwords $ map show $ length xs:xs, unwords $ map show $ length ys:ys]) . solve . read

solve 1 = Nothing
solve n | s <- n * (n + 1) `quot` 2 = case [i | i <- [1..n], gcd i (s - i) /= 1] of
  [] -> Nothing
  (i:_) -> Just ([i], [1..i - 1] ++ [i + 1..n])

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

main = sol <$> readLn >>= mapM_ putStrLn

sol n = if n > 2
    then ["Yes", put s1, put s2]
    else ["No"]
    where
    s1 = 1:[n]
    s2 = 2:[1..n-1]

put = unwords . fmap show

module Main where
import Data.Maybe

default (Int)
main = interact $ maybe "No" (\(xs, ys) -> unlines ["Yes", unwords $ map show $ length xs:xs, unwords $ map show $ length ys:ys]) . solve . read

solve 1 = Nothing
solve 2 = Just ([1], [2])
solve n
  | odd (length os) = Just (tail es, 2:os)
  | otherwise = Just (es, os)
  where
    es = [2, 4..n]
    os = [1, 3..n]


A queen is the strongest chess piece. In modern chess the queen can move any number of squares in any horizontal, vertical or diagonal direction (considering that there're no other pieces on its way). The queen combines the options given to the rook and the bishop.There are m queens on a square n × n chessboard. You know each queen's positions, the i-th queen is positioned in the square (ri, ci), where ri is the board row number (numbered from the top to the bottom from 1 to n), and ci is the board's column number (numbered from the left to the right from 1 to n). No two queens share the same position.For each queen one can count w — the number of other queens that the given queen threatens (attacks). For a fixed attack direction only the first queen in this direction is under attack if there are many queens are on the ray of the attack. Obviously, for any queen w is between 0 and 8, inclusive.Print the sequence t0, t1, ..., t8, where ti is the number of queens that threaten exactly i other queens, i.e. the number of queens that their w equals i.

The first line of the input contains a pair of integers n, m (1 ≤ n, m ≤ 105), where n is the size of the board and m is the number of queens on the board. Then m following lines contain positions of the queens, one per line. Each line contains a pair of integers ri, ci (1 ≤ ri, ci ≤ n) — the queen's position. No two queens stand on the same square.

Print the required sequence t0, t1, ..., t8, separating the numbers with spaces.

{-# OPTIONS_GHC -O2 -optc-O2 #-}

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

createRow [] acc = acc
createRow ((row,col) : xs) acc
  | (IntMap.member row acc) == False = createRow xs (IntMap.insert row (col,col) acc)
  | otherwise                        = let (minCol,maxCol) = (IntMap.findWithDefault (0,0) row acc)
                                       in
                                       if (col < minCol) then createRow xs (IntMap.update (\x -> Just (col,maxCol)) row acc)
                                       else if (col > maxCol) then createRow xs (IntMap.update (\x -> Just (minCol,col)) row acc)
                                        else createRow xs acc

createCol [] acc = acc
createCol ((row,col) : xs) acc
  | (IntMap.member col acc) == False = createCol xs (IntMap.insert col (row,row) acc)
  | otherwise                        = let (minRow,maxRow) = (IntMap.findWithDefault (0,0) col acc)
                                       in
                                       if (row < minRow) then createCol xs (IntMap.update (\x -> Just (row,maxRow)) col acc)
                                       else if (row > maxRow) then createCol xs (IntMap.update (\x -> Just (minRow,row)) col acc)
                                        else createCol xs acc

createDiag [] acc f = acc
createDiag ((row,col) : xs) acc f
  | (IntMap.member (f row col) acc) == False = createDiag xs (IntMap.insert (f row col) ((row,col),(row,col)) acc) f
  | otherwise                        = let ((minRow,minCol),(maxRow,maxCol)) = (IntMap.findWithDefault ((0,0),(0,0)) (f row col) acc)
                                       in
                                       if (row < minRow) then createDiag xs (IntMap.update (\x -> Just ((row,col),(maxRow,maxCol))) (f row col) acc) f
                                       else if (row > maxRow) then createDiag xs (IntMap.update (\x -> Just ((minRow,minCol),(row,col))) (f row col) acc) f
                                        else createDiag xs acc f

checkRow (row,col) rows =
  let (minCol,maxCol) = (IntMap.findWithDefault (0,0) row rows)
  in
  case (col > minCol) of True -> if (col < maxCol) then 2 else 1
                         False -> if (col < maxCol) then 1 else 0

checkCol (row,col) cols =
  let (minRow,maxRow) = (IntMap.findWithDefault (0,0) col cols)
  in
  case (row > minRow) of True -> if (row < maxRow) then 2 else 1
                         False -> if (row < maxRow) then 1 else 0

checkDiag (row,col) diag f =
  let d = f row col in
  let ((minRow,minCol),(maxRow,maxCol)) = (IntMap.findWithDefault ((0,0),(0,0)) d diag)
  in
  case (row > minRow) of True -> if (row < maxRow) then 2 else 1
                         False -> if (row < maxRow) then 1 else 0

check [] rows cols diag1 diag2 t = t
check ((row,col) : xs) rows cols diag1 diag2 t =
  let threats = (checkRow (row,col) rows) + (checkCol (row,col) cols) + (checkDiag (row,col) diag1 (-)) + (checkDiag (row,col) diag2 (+)) in
    case (IntMap.member threats t) of False -> check xs rows cols diag1 diag2 (IntMap.insert threats 1 t)
                                      True -> check xs rows cols diag1 diag2 (IntMap.adjust (1+) threats t)

main :: IO ()
main =
  do all <- BS.getContents
     let Just (n, r1) = readInt all
     let Just (m, r2) = readInt r1
     let Just (board, r3) = readIntList m r2
     let rows = createRow board (IntMap.empty)
     let cols = createCol board (IntMap.empty)
     let diag1 = createDiag board (IntMap.empty) (-)
     let diag2 = createDiag board (IntMap.empty) (+)
     let tSeq = check board rows cols diag1 diag2 (IntMap.empty)
     printResult tSeq 0
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readIntList 0 s = do return ([], s)
        readIntList n s = do (row, r) <- readInt s
                             (col, z) <- readInt r
                             (l, t) <- readIntList (n-1) z
                             return ((row,col) : l, t)
        printResult l 9 = putStrLn ""
        printResult l n = do
                            let v = IntMap.findWithDefault 0 n l
                            putStr $ show v ++ " "
                            printResult l (n+1)


Consider an array $$$a$$$ of $$$n$$$ positive integers.You may perform the following operation:   select two indices $$$l$$$ and $$$r$$$ ($$$1 \leq l \leq r \leq n$$$), then  decrease all elements $$$a_l, a_{l + 1}, \dots, a_r$$$ by $$$1$$$. Let's call $$$f(a)$$$ the minimum number of operations needed to change array $$$a$$$ into an array of $$$n$$$ zeros.Determine if for all permutations$$$^\dagger$$$ $$$b$$$ of $$$a$$$, $$$f(a) \leq f(b)$$$ is true. $$$^\dagger$$$ An array $$$b$$$ is a permutation of an array $$$a$$$ if $$$b$$$ consists of the elements of $$$a$$$ in arbitrary order. For example, $$$[4,2,3,4]$$$ is a permutation of $$$[3,2,4,4]$$$ while $$$[1,2,2]$$$ is not a permutation of $$$[1,2,3]$$$.

The first line contains a single integer $$$t$$$ ($$$1 \leq t \leq 10^4$$$) — the number of test cases. The first line of each test case contains a single integer $$$n$$$ ($$$1 \leq n \leq 10^5$$$) — the length of the array $$$a$$$. The second line contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i \le 10^9$$$) — description of the array $$$a$$$. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$10^5$$$.

For each test case, print "YES" (without quotes) if for all permutations $$$b$$$ of $$$a$$$, $$$f(a) \leq f(b)$$$ is true, and "NO" (without quotes) otherwise. You can output "YES" and "NO" in any case (for example, strings "yEs", "yes" and "Yes" will be recognized as a positive response).

NoteIn the first test case, we can change all elements to $$$0$$$ in $$$5$$$ operations. It can be shown that no permutation of $$$[2, 3, 5, 4]$$$ requires less than $$$5$$$ operations to change all elements to $$$0$$$.In the third test case, we need $$$5$$$ operations to change all elements to $$$0$$$, while $$$[2, 3, 3, 1]$$$ only needs $$$3$$$ operations.

--
-- Michael V. Antosha
-- 2022
-- Michael.Antosha@gmail.com
--

{-# language Safe                      #-}
{-# language ImportQualifiedPost       #-}
{-# language NoMonomorphismRestriction #-}

{-# options_ghc -O3                              #-}

{-# options_ghc -Weverything                     #-}
{-# options_ghc -Werror                          #-}

{-# options_ghc -Wno-missing-import-lists        #-}
{-# options_ghc -Wno-missing-local-signatures    #-}

import Prelude               hiding (getLine)
import Control.Arrow
import Control.Monad
import Data.ByteString.Char8 qualified as B
import Data.Char
import Data.List             qualified as L

ri = readInts <$> B.getLine :: IO [Int]
  where
    readInts  = L.unfoldr ((second dropSpace <$>) . B.readInt) . dropSpace
    dropSpace = B.dropWhile isSpace

main :: IO ()
main = do
    [t] <- ri
    tcs <- replicateM t $ do
        [[n], xs] <- replicateM 2 ri
        return (n,xs)
    mapM_ (putStrLn.showB.solve) tcs

showB False = "NO"
showB True  = "YES"

solve (_n,xs) = null adSkipped
  where
    dw = dropWhile . uncurry
    adSkipped = dw (>=) . dw (<=) $ zip xs (tail xs)

--
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -O3 -funbox-strict-fields -fvia-C -optc-O3 #-}

import Control.Arrow ((>>>))
import Control.Monad (
    MonadPlus (mplus),
    foldM_,
    forM_,
    guard,
    join,
    replicateM,
    replicateM_,
 )
import qualified Control.Monad as M
import qualified Control.Monad.ST.Strict as ST
import qualified Control.Monad.State.Strict as S
import qualified Control.Monad.Trans.Class as T

import qualified Data.Array as A
import qualified Data.Array.MArray.Safe as MA
import qualified Data.Array.IO.Safe as IOA
import qualified Data.Array.ST.Safe as STA
import qualified Data.Array.Unboxed as UA

import Data.Bits
import qualified Data.ByteString.Char8 as B8
import Data.Char
import Data.Int

import Data.Function (on)
import Data.Functor ((<&>))
import Data.Bifunctor (bimap)
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Maybe as MB

import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.List   as L
import Data.List (
    elemIndices,
    find,
    findIndices,
    intersect,
    isPrefixOf,
    nub,
    sort,
    sortOn,
 )
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Ix as Ix
import qualified Data.Ratio as R

import Control.Monad.Cont (MonadIO (liftIO))
import Data.IORef (modifyIORef, newIORef, readIORef)
import GHC.IO.Handle (hDuplicateTo)
import System.IO (
    IOMode (ReadMode, WriteMode),
    openFile,
    stdin,
    stdout,
    hFlush
 )
import System.Posix.Internals (puts)
import Text.Printf (printf)
import qualified Data.Array.IO.Safe as UOA

-- import Debug.Trace (trace, traceM, traceShowM)
-- debug = flip trace
--
-- tracing t x = trace (t ++ " = " ++ show x) x
-- debugging x t = tracing t x

-- debug x t = x
-- trace t x = x
-- tracing t x = x
-- debugging x t = x

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

readIntB8s :: B8.ByteString -> [Int]
readIntB8s = B8.words >>> map (B8.readInt >>> (fst . fromJust))

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

readIntegerB8s :: B8.ByteString -> [Integer]
readIntegerB8s = B8.words >>> map (B8.readInteger >>> (fst . fromJust))

modifyArray :: (MA.MArray a e m, MA.Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray arr ix f = do
    value <- MA.readArray arr ix
    MA.writeArray arr ix $ f value

putsYesNo :: Bool -> IO ()
putsYesNo value = do
    let result :: String =
            if value
                then "YES"
                else "NO"
    printf "%s\n" result

{- END OF GENERAL -}

solve :: Int -> [Int] -> Bool
solve n as = (increasingA + decreasingA) >= length as
    where
        increasingA = increasingSeq as
        decreasingA = increasingSeq $ reverse as

        increasingSeq :: [Int] -> Int
        increasingSeq as = length . takeWhile (uncurry (>=)) $ zip as (0 : as)

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        n <- B8.getLine <&> readIntB8
        as <- B8.getLine <&> readIntB8s
        let answer = solve n as
        putsYesNo answer


A bracket sequence is called regular if it is possible to obtain correct arithmetic expression by inserting characters «+» and «1» into this sequence. For example, sequences «(())()», «()» and «(()(()))» are regular, while «)(», «(()» and «(()))(» are not.One day Johnny got bracket sequence. He decided to remove some of the brackets from it in order to obtain a regular bracket sequence. What is the maximum length of a regular bracket sequence which can be obtained?

Input consists of a single line with non-empty string of «(» and «)» characters. Its length does not exceed 106.

Output the maximum possible length of a regular bracket sequence.

import Data.List
main = do getLine >>= print . fst . foldl f (0, 0)
f (a, b) '(' = (a, b + 1)
f (a, 0) ')' = (a, 0)
f (a, b) ')' = (a + 2, b - 1)

solve ans _ [] = ans
solve ans n ('(':xs) = solve ans (n+1) xs
solve ans 0 (')':xs) = solve ans 0 xs
solve ans n (')':xs) = solve (ans+2) (n-1) xs

main = getLine >>= print . solve 0 0

count_regular b ct [] = ct - b
count_regular b ct ('(':xs) = count_regular (succ b) (succ ct) xs
count_regular b ct (')':xs)
    | b > 0 = count_regular (pred b) (succ ct) xs
    | otherwise = count_regular b ct xs

main :: IO ()
main = do
    seq <- getLine
    print (count_regular 0 0 seq)

import Control.Monad (liftM, replicateM, replicateM_)
import Data.Array
import Data.List (intercalate)
import Prelude hiding (reads)

reads :: Read a => IO [a]
reads  =  liftM (map read . words) getLine

prints :: Show a => [a] -> IO ()
prints  =  putStrLn . intercalate " " . map show

solve :: String -> Int
solve s  =  solve' 0 s
  where
    solve' n ""  =  (-n)
    solve' 0 (')':s)  =  solve' 0 s
    solve' n ('(':s)  =  1 + solve' (n+1) s
    solve' n (')':s)  =  1 + solve' (n-1) s

main :: IO ()
main  =  getLine >>= print . solve

-- Codeforces 26B

{-# OPTIONS_GHC -O2 #-}
{-# OPTIONS_GHC -optc-O2 #-}
{-# LANGUAGE BangPatterns #-}

import Control.Applicative
import Data.List

main :: IO ()
main = let match !(!a, !b) '(' = (a, b + 1)
           match !(!a, 0) ')' = (a, 0)
           match !(!a, !b) ')' = (a + 2, b - 1)
        in getLine >>= print . fst . foldl' match (0, 0)

correct good open [] = good
correct good open ('(':xs) = correct good (open+1) xs
correct good open (')':xs) | open > 0 = correct (good+2) (open-1) xs
                           | otherwise = correct good open xs
main = correct 0 0 `fmap` getLine >>= print

{-# LANGUAGE BangPatterns #-}

import Control.Applicative
import Control.Monad

count :: (Int, Int) -> Char -> (Int, Int)
count state@(!n, !answer) c
  | c == '('   = (n + 1, answer)
  | n > 0      = (n - 1, answer + 2)
  | otherwise  = state

solve :: String -> IO ()
solve = putStrLn . show . snd . foldl count (0, 0)

main :: IO ()
main = getLine >>= solve

import Data.List

minDelCount :: String -> Int
minDelCount xs =
    let (d, h) = foldl' counter (0, 0) xs in
    if d < 0 then (- d) + max (h - d) 0
             else max h 0
    where
    counter (d, h) c = h' `seq` d `seq` (min h' d, h')
        where
        h' = case c of
            '(' -> h + 1
            ')' -> h - 1

main :: IO ()
main = do
    line <- getLine
    putStrLn $ show $ (length line) - (minDelCount line)

f l [] = -l
f l (x:xs)
	| x == '(' = f (l + 1) xs + 1
	| x == ')' = if l > 0 then f (l - 1) xs + 1 else f l xs

main = do
	s <- getLine
	putStrLn . show $ f 0 s

{-# LANGUAGE BangPatterns #-}

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

type Index = Int
type Range = (Index, Index)
type State = ([Index], [Range])

automata :: State -> (Index, Char) -> State
automata state@(stack, ranges) (i, c)
  | c == '('   = (i : stack, ranges)
  | null stack = state
  | otherwise  = update state i

update :: State -> Index -> State
update (!i : stack, ranges) !j = (,) stack . ((i, j) :) $ do
  x@(i', j') <- ranges
  guard $ j' < i || j < i'
  return x

exec :: String -> [Range]
exec = reverse . snd . foldl automata ([], []) . zip [0 ..]

merge :: [Range] -> [Int]
merge (x@(a, b) : y@(c, d) : zs)
  | b + 1 == c      = merge ((a, d) : zs)
  | otherwise       = b - a + 1 : merge (y : zs)
merge ((a, b) : zs) = b - a + 1 : merge zs
merge _             = [ 0 ]

solve :: String -> IO ()
solve = putStrLn . show . maximum . merge . exec

main = getLine >>= solve

{-# LANGUAGE BangPatterns #-}

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

type Index  = Int
type Depth  = Int
type Stack  = (Depth, Depth, [Index])
type State  = (Stack, (Int, Int))

push :: Index -> State -> State
push i ((d, e, is), best)
  | d == e    = ((d', d', i : is), best)
  | otherwise = ((d', e, is), best)
 where d' = d + 1

pop :: Index -> State -> State
pop i ((!d, !e, is), best@(!longest, !count))
  | d == 0    = ((0, 0, []), best)
  | otherwise = (,) (d - 1, d, is') $ case compare l longest of
    LT -> best
    EQ -> fmap succ best
    GT -> (l, 1)
 where is' = drop (e - d) is
       l = i - head is' + 1

automata :: State -> (Index, Char) -> State
automata state (i, c)
  | c == '('   = push i state
  | otherwise  = pop  i state

solve :: String -> IO ()
solve = putStrLn . show . fst
      . snd . foldl automata ((0, 0, []), (0, 1)) . zip [0 ..]

main :: IO ()
main = getLine >>= solve

{-# LANGUAGE BangPatterns #-}

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

type Index = Int
type Longest = Int
type State = ([Index], Longest)

automata :: State -> (Index, Char) -> State
automata state@(stack, !best) (i, c)
  | c == '('   = (i : stack, best)
  | null stack = state
  | otherwise  = update state i

update :: State -> Index -> State
update (j : stack, best) i =
  case compare l best of
    GT -> (stack, l)
    _  -> (stack, best)
 where l = i - j + 1

exec :: String -> Longest
exec = snd . foldl automata ([], 0) . zip [0 ..]

solve :: String -> IO ()
solve = putStrLn . show . exec

main = getLine >>= solve

import Data.List

minDelCount :: String -> Int
minDelCount xs =
    let (d, h) = foldl' counter (0, 0) xs in
    if      d < 0 then (- d) + max (h - d) 0
    else if h > 0 then h
    else               0
    where
    counter (d, h) c = h' `seq` d `seq` (min h' d, h')
        where
        h' = case c of
            '(' -> h - 1
            ')' -> h + 1

main :: IO ()
main = do
    line <- getLine
    putStrLn $ show $ (length line) - (minDelCount line)


You have a string $$$s$$$ consisting of lowercase Latin alphabet letters. You can color some letters in colors from $$$1$$$ to $$$k$$$. It is not necessary to paint all the letters. But for each color, there must be a letter painted in that color.Then you can swap any two symbols painted in the same color as many times as you want. After that, $$$k$$$ strings will be created, $$$i$$$-th of them will contain all the characters colored in the color $$$i$$$, written in the order of their sequence in the string $$$s$$$.Your task is to color the characters of the string so that all the resulting $$$k$$$ strings are palindromes, and the length of the shortest of these $$$k$$$ strings is as large as possible.Read the note for the first test case of the example if you need a clarification.Recall that a string is a palindrome if it reads the same way both from left to right and from right to left. For example, the strings abacaba, cccc, z and dxd are palindromes, but the strings abab and aaabaa — are not.

The first line of input data contains a single integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of input data sets in the test.  The descriptions of the input data sets follow. The first line of the description of each input data set contains two integers $$$n$$$ and $$$k$$$ ($$$1 \le k \le n \le 2 \cdot 10^5$$$) — the length of the string and the number of colors in which its letters can be painted. The second line of the description of each input data set contains a string $$$s$$$ of length $$$n$$$ consisting of lowercase letters of the Latin alphabet. It is guaranteed that the sum of n over all test cases does not exceed $$$2 \cdot 10^5$$$.

For each set of input data, output a single integer  — the maximum length of the shortest palindrome string that can be obtained.

10

8 2

bxyaxzay

6 3

aaaaaa

6 1

abcdef

6 6

abcdef

3 2

dxd

11 2

abcabcabcac

6 6

sipkic

7 2

eatoohd

3 1

llw

6 2

bfvfbv

Note In the first test case, $$$s$$$="bxyaxzay", $$$k=2$$$. We use indices in the string from $$$1$$$ to $$$8$$$. The following coloring will work: $$$\mathtt{\mathbf{\color{red}{b}\color{blue}{xy}\color{red}{a}\color{blue}{x}z\color{red}{a}\color{blue}{y}}}$$$ (the letter z remained uncolored). After painting:  swap two red characters (with the indices $$$1$$$ and $$$4$$$), we get $$$\mathtt{\mathbf{\color{red}{a}\color{blue}{xy}\color{red}{b}\color{blue}{x}z\color{red}{a}\color{blue}{y}}}$$$;  swap two blue characters (with the indices $$$5$$$ and $$$8$$$), we get $$$\mathtt{\mathbf{\color{red}{a}\color{blue}{xy}\color{red}{b}\color{blue}{y}z\color{red}{a}\color{blue}{x}}}$$$. Now, for each of the two colors we write out the corresponding characters from left to right, we get two strings $$$\mathtt{\mathbf{\color{red}{aba}}}$$$ and $$$\mathtt{\mathbf{\color{blue}{xyyx}}}$$$. Both of them are palindromes, the length of the shortest is $$$3$$$. It can be shown that the greatest length of the shortest palindrome cannot be achieved. In the second set of input data, the following coloring is suitable: $$$[1, 1, 2, 2, 3, 3]$$$. There is no need to swap characters. Both received strings are equal to aa, they are palindromes and their length is $$$2$$$. In the third set of input data, you can color any character and take it into a string. In the fourth set of input data, you can color the $$$i$$$th character in the color $$$i$$$. In the fifth set of input data can be colored in each of the colors of one character. In the sixth set of input data, the following coloring is suitable: $$$[1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 0]$$$. Rearrange the characters so as to get the palindromes abcba and acbca.

import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as C

solve :: IO ()
solve = do
    ~[n, k] <- readInts
    s <- takeWhile (not . isSpace) . C.unpack <$> C.getLine
    let (es, os) = unzip $ map ((`divMod` 2) . length) $ group $ sort s
        (len, erem) = sum es `divMod` k
    print $ 2 * len + fromEnum (sum os + 2 * erem >= k)

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

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

import qualified Data.ByteString.Lazy.Char8 as P
import Data.ByteString.Builder
import qualified Data.ByteString.Builder.Prim as Prim
import System.IO
import Control.Monad.Trans.State
import Data.Maybe

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

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, k] <- getInts 2
    ~[s] <- getNext 1
    let
      cts :: UArray Char Int
      cts = accumArray (+) 0 ('a', 'z') $ P.unpack s `zip` repeat 1
      oddCts = length $ filter odd $ elems cts
      evOpts = foldl' (+) 0 $ map (`div` 2) $ elems cts
      ans = case  evOpts `quotRem` k of
        (q, r) | 2*r + oddCts >= k  -> 2*q + 1
               | otherwise          -> 2*q
    pure $ putInts [ans]

type SP = State [P.ByteString]

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

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

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

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

import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as C

solve :: IO ()
solve = do
    ~[n, k] <- readInts
    s <- takeWhile (not . isSpace) . C.unpack <$> C.getLine
    let (es, os) = unzip $ map ((`divMod` 2) . length) $ group $ sort s
        (len, erem) = sum es `divMod` k
    print $ 2 * len + fromEnum (sum os + 2 * erem >= len)

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

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

import Control.Monad
import Data.Char
import Data.Bifunctor
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as C

solve :: IO ()
solve = do
    ~[n, k] <- readInts
    s <- takeWhile (not . isSpace) . C.unpack <$> C.getLine
    let (esum, osum) = bimap sum sum $ unzip $ map ((`divMod` 2) . length) $ group $ sort s
        (len, erem) = esum `divMod` k
    print $ len * 2 + fromEnum (osum + erem >= len)

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

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

import Control.Monad
import Data.Bifunctor
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as C

solve :: IO ()
solve = do
    ~[n, k] <- readInts
    s <- C.unpack <$> C.getLine
    let (esum, osum) = bimap sum sum $ unzip $ map ((`divMod` 2) . length) $ group $ sort s
        (len, erem) = esum `divMod` k
    print $ len * 2 + fromEnum (osum + erem >= len)

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

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


Masha meets a new friend and learns his phone number — $$$s$$$. She wants to remember it as soon as possible. The phone number — is a string of length $$$m$$$ that consists of digits from $$$0$$$ to $$$9$$$. The phone number may start with 0.Masha already knows $$$n$$$ phone numbers (all numbers have the same length $$$m$$$). It will be easier for her to remember a new number if the $$$s$$$ is represented as segments of numbers she already knows. Each such segment must be of length at least $$$2$$$, otherwise there will be too many segments and Masha will get confused.For example, Masha needs to remember the number: $$$s = $$$ '12345678' and she already knows $$$n = 4$$$ numbers: '12340219', '20215601', '56782022', '12300678'. You can represent $$$s$$$ as a $$$3$$$ segment: '1234' of number one, '56' of number two, and '78' of number three. There are other ways to represent $$$s$$$.Masha asks you for help, she asks you to break the string $$$s$$$ into segments of length $$$2$$$ or more of the numbers she already knows. If there are several possible answers, print any of them.

The first line of input data contains an integer $$$t$$$ ($$$1 \le t \le 10^4$$$) —the number of test cases. Before each test case there is a blank line. Then there is a line containing integers $$$n$$$ and $$$m$$$ ($$$1 \le n, m \le 10^3$$$) —the number of phone numbers that Masha knows and the number of digits in each phone number. Then follow $$$n$$$ line, $$$i$$$-th of which describes the $$$i$$$-th number that Masha knows. The next line contains the phone number of her new friend $$$s$$$. Among the given $$$n+1$$$ phones, there may be duplicates (identical phones). It is guaranteed that the sum of $$$n \cdot m$$$ ($$$n$$$ multiplied by $$$m$$$) values over all input test cases does not exceed $$$10^6$$$.

You need to print the answers to $$$t$$$ test cases. The first line of the answer should contain one number $$$k$$$, corresponding to the number of segments into which you split the phone number $$$s$$$. Print -1 if you cannot get such a split. If the answer is yes, then follow $$$k$$$ lines containing triples of numbers $$$l, r, i$$$. Such triplets mean that the next $$$r-l+1$$$ digits of number $$$s$$$ are equal to a segment (substring) with boundaries $$$[l, r]$$$ of the phone under number $$$i$$$. Both the phones and the digits in them are numbered from $$$1$$$. Note that $$$r-l+1 \ge 2$$$ for all $$$k$$$ lines.

NoteThe example from the statement.In the second case, it is impossible to represent by segments of known numbers of length 2 or more.In the third case, you can get the segments '12' and '21' from the first phone number.

import Control.Applicative
import Control.Monad
import Data.Array
import Data.Maybe
import qualified Data.ByteString.Char8 as C
import qualified Data.Map.Strict as M

data Pos = Pos { i_ :: !Int, l_ :: !Int, n_ :: !Int }

fmtPos :: Pos -> String
fmtPos (Pos i l n) = unwords $ map show [l, l + n - 1, i]

solve :: IO ()
solve = do
    void C.getLine -- why?
    ~[n, m] <- readInts
    xs <- replicateM n C.getLine
    y <- C.getLine
    let pieces d = M.fromList
            [ (C.take d x', Pos i l d)
            | (i, x) <- zip [1..] xs
            , (l, x') <- zip [1..] (C.tails x)
            , C.length x' >= d
            ]
        (twos, threes) = (pieces 2, pieces 3)
        dp = fArray (0, m) f where
            f i | i == m     = Just []
                | i == m - 1 = Nothing
                | i == m - 2 = tryn twos 2 i
                | otherwise  = tryn twos 2 i <|> tryn threes 3 i
        tryn mp d i = (:) <$> mp M.!? C.take d (C.drop i y) <*> dp!(i + d)
    mapM_ putStrLn $ maybe ["-1"] ((:) <$> show . length <*> map fmtPos) $ dp!0

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

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

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

import Control.Applicative
import Control.Monad
import Data.Array
import Data.Maybe
import qualified Data.ByteString.Char8 as C
import qualified Data.Map.Strict as M

data Pos = Pos { i_ :: !Int, l_ :: !Int, n_ :: !Int }

fmtPos :: Pos -> String
fmtPos (Pos i l n) = unwords $ map show [l, l + n - 1, i]

solve :: IO ()
solve = do
    void C.getLine -- why?
    ~[n, m] <- readInts
    xs <- replicateM n C.getLine
    y <- C.getLine
    let xs'    = [(x', Pos i l) | (i, x) <- zip [1..] xs, (l, x') <- zip [1..] $ C.tails x]
        twos   = M.fromList [(C.take 2 x, p 2) | (x, p) <- xs', C.length x >= 2]
        threes = M.fromList [(C.take 3 x, p 3) | (x, p) <- xs', C.length x >= 3]
        dp = fArray (0, m) f where
            f i | i == m     = Just []
                | i == m - 1 = Nothing
                | i == m - 2 = tryn twos 2 i
                | otherwise  = tryn twos 2 i <|> tryn threes 3 i
        tryn m d i = liftA2 (:) (m M.!? C.take d (C.drop i y)) (dp!(i + d))
    putStr $ unlines $ maybe ["-1"] (liftA2 (:) (show . length) (map fmtPos)) $ dp!0

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

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

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

import qualified Data.ByteString.Lazy.Char8 as P
import Data.ByteString.Builder
import qualified Data.ByteString.Builder.Prim as Prim
import System.IO
import Control.Monad.Trans.State
import Data.Maybe

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

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    known <- getNext n
    ~[tar] <- getNext 1
    let
      try s len = let
        s' = P.take len s
        in  if  P.length s' == len
        then  Just $! parseInt s'
        else  Nothing
      opts len = S.fromListWith const $ do
        (curr, i) <- zip known [1..]
        (currt, j) <- P.tails curr `zip` [1..]
        maybeToList $ flip (,) (i, j) <$> try currt len
      o2 = opts 2
      o3 = opts 3
    -- ugly type: holds up to one possible history for each of next 3 positions
      go :: P.ByteString -> Maybe [[Int]] -> Maybe [[Int]] -> Maybe [[Int]] -> Maybe [[Int]]
      go s c0 c1 c2 = if  P.null s
        then  c0
        else  let
        c2' = case  try s 2  of
          _ | isJust c2 -> c2
          Just v | isJust c0 && isNothing c2
            -> case  S.lookup v o2  of
                 Just (i, j) -> Just ([j, j+1, i] : fromJust c0)
                 Nothing -> Nothing
          _ -> Nothing
        c3' = case  try s 3  of
          Just v | isJust c0
            -> case  S.lookup v o3  of
                 Just (i, j) -> Just ([j, j+2, i] : fromJust c0)
                 Nothing -> Nothing
          _ -> Nothing
        in  go (P.tail s) c1 c2' c3'
    pure $ case  go tar (Just []) Nothing Nothing  of
      Nothing -> string7 "-1\n"
      Just ans -> putInts [length ans] <> foldMap putInts (reverse ans)

type SP = State [P.ByteString]

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

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

getInts :: Int -> SP [Int]
getInts k = map parseInt <$> getNext k

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

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


Consider a table of size $$$n \times m$$$, initially fully white. Rows are numbered $$$1$$$ through $$$n$$$ from top to bottom, columns $$$1$$$ through $$$m$$$ from left to right. Some square inside the table with odd side length was painted black. Find the center of this square.

The first line contains two integers $$$n$$$ and $$$m$$$ ($$$1 \le n, m \le 115$$$) — the number of rows and the number of columns in the table. The $$$i$$$-th of the next $$$n$$$ lines contains a string of $$$m$$$ characters $$$s_{i1} s_{i2} \ldots s_{im}$$$ ($$$s_{ij}$$$ is 'W' for white cells and 'B' for black cells), describing the $$$i$$$-th row of the table.

Output two integers $$$r$$$ and $$$c$$$ ($$$1 \le r \le n$$$, $$$1 \le c \le m$$$) separated by a space — the row and column numbers of the center of the black square.

--import Debug.Trace
import qualified Data.ByteString.Char8 as B
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.List
import Data.Maybe

main = do
  [n,m] <- lineInts
  board <- replicateM n getLine
  let (u,d) = g board
      (l,r) = g $ transpose board
  putStrLn $ unwords $ map (show . flip div 2) [l+r, u+d]

f l = if null t then (100000, 0) else (fst $ head t, fst $ last t)
  where t = filter (\(_,y) -> y == 'B') (zip [1..] l)
g :: [String] -> (Int, Int)
g = foldr ((\(x,y) -> min x *** max y). f) (100000,0)

-- Below is template code
readInt = fst . fromJust . B.readInt
lineInt = readInt <$> B.getLine
lineInts = map readInt . B.words <$> B.getLine

--infixr 0 ##
--(##) x msg = traceShow msg x

-- Codeforces 1028A

import Data.List

findFirst :: [String] -> Int
findFirst (x:xs)
    | "B" `isInfixOf` x = 0
    | otherwise = 1 + findFirst xs

rowProperty :: [String] -> (Int, Int)
rowProperty list = (start, height)
    where start = length (takeWhile (\s -> not ("B" `isInfixOf` s)) list)
          height = length (takeWhile (\s -> "B" `isInfixOf` s) (drop start list))
row :: [String] -> Int
row c = start + 1 + (height `div` 2)
    where (start, height) = rowProperty c

columnProperty :: String -> (Int, Int)
columnProperty row = (start, width)
    where start = length (takeWhile (\a -> a /= 'B') row)
          width = length (takeWhile (\a -> a == 'B') (drop start row))

column :: String -> Int
column r = start + 1 + (width `div` 2)
    where (start, width) = columnProperty r

position :: [String] -> (Int, Int)
position list = (r, c)
    where r = row list
          c = column (head (drop (r - 1) list))

main :: IO ()
main = do
    something <- getLine
    board <- getContents
    let list = lines board
    let (r, c) = position list
    putStrLn ((show r) ++ " " ++ (show c))

import Data.List

f ::Int->[String]->Int
f _ []=0
f n (x:xs)
   |'B' `elem` x=let Just t=findIndex (=='B') x
                     Just t2=findIndex (=='B') $ reverse x
                 in (t+(n-1-t2)) `div` 2+1
   |otherwise=f n xs

main = do
       e<-getLine
       es<-getContents
       let xs=lines es
           (h:w:[])=map read (words e)::[Int]
       putStrLn $ (show (f h (transpose xs)))++" "++(show (f w xs))

import Data.List

doit :: [String] -> Int
doit s = let tmp = map snd . filter (any (== 'B') . fst) . zip s $ [1..]
				 in (minimum tmp + maximum tmp) `div` 2

main = do
	getLine
	l <- fmap lines getContents
	putStrLn . unwords . map show . map doit $ [l, transpose l]

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

ws x = all (=='W') x

main = do
		[n,m]<-map read <$> words <$> getLine ::IO [Int]
		s<- replicateM n getLine
		let s1 =  head  $ dropWhile ws s
		let hs = (+1) $ length $ takeWhile (=='W') s1
		let he = (+hs) $   length  $ takeWhile (=='B') $ dropWhile (=='W') s1
		let s2 = head $ dropWhile ws $ transpose s
		let vs =(+1) $  length $ takeWhile (=='W') s2
		let ve = (+vs) $ length  $ takeWhile (=='B') $ dropWhile (=='W') s2
		putStr $ show $ div (ve+vs)  2
		putStr " "
		putStrLn $ show $ div (he+ hs) 2

process :: [[Char]] -> (Int,Int)
process ss = fr ss
    where
        fc xs
            | null xs' = []
            | otherwise = [head xs' + (length xs')`div`2]
            where xs' = concat $ zipWith (\x n -> if x=='B' then [n] else []) xs [1..]

        fr ss = ss' !! (length ss' `div` 2)
            where ss' = concat $ zipWith (\s n -> if null s then [] else [(n,head s)]) (map fc ss) [1..]

readInt :: String -> Int
readInt = read

main :: IO ()
main = do
    [n,m] <- fmap (map readInt.words) getLine
    s <- fmap lines getContents
    let (r,c) = process s
    putStrLn (show r ++ " " ++ show c)


Piegirl is buying stickers for a project. Stickers come on sheets, and each sheet of stickers contains exactly n stickers. Each sticker has exactly one character printed on it, so a sheet of stickers can be described by a string of length n. Piegirl wants to create a string s using stickers. She may buy as many sheets of stickers as she wants, and may specify any string of length n for the sheets, but all the sheets must be identical, so the string is the same for all sheets. Once she attains the sheets of stickers, she will take some of the stickers from the sheets and arrange (in any order) them to form s. Determine the minimum number of sheets she has to buy, and provide a string describing a possible sheet of stickers she should buy.

The first line contains string s (1 ≤ |s| ≤ 1000), consisting of lowercase English characters only. The second line contains an integer n (1 ≤ n ≤ 1000).

On the first line, print the minimum number of sheets Piegirl has to buy. On the second line, print a string consisting of n lower case English characters. This string should describe a sheet of stickers that Piegirl can buy in order to minimize the number of sheets. If Piegirl cannot possibly form the string s, print instead a single line with the number -1.

NoteIn the second example, Piegirl can order 3 sheets of stickers with the characters "nab". She can take characters "nab" from the first sheet, "na" from the second, and "a" from the third, and arrange them to from "banana".

import Data.List

import Control.Monad
import Control.Arrow
import Debug.Trace
main = do
    l <- getLine
    n <- fmap read getLine
    let (i,s) = solve l n
    print i
    when (i /= -1) $ putStrLn s

itof :: Int -> Double
itof= fromIntegral

solve :: String -> Int -> (Int,String)
solve l n | not (can l' n (length l+1)) = (-1,"")
          | otherwise        = (k,take n $s ++ repeat 'a')
    where
    l' = map length l0
    l0 = group $ sort l
    k = binSearch (can l' n) 1 (length l+1)
    s = construct l0 n k

can :: [Int] -> Int -> Int -> Bool
can l n k = (<=n) $ sum $ map (\c -> ceiling (itof c / itof k)) l

binSearch f i j | i + 1 == j = if f i then i else j
                | f m        = binSearch f i m
                | otherwise  = binSearch f m j
    where
    m = (i+j) `div` 2

construct l n k = concat $ map (\l ->
    take (ceiling (itof (length l) / itof k)) l) l

import Control.Monad (liftM, liftM2)
import Data.List (group, sort, sortBy)
import Data.Ratio ((%))
import Prelude hiding (reads)

reads :: Read a => IO [a]
reads  =  liftM (map read . words) getLine

solve :: String -> Int -> Maybe (Int, String)
solve s n
  | length g > n  =  Nothing
  | otherwise  =  solve' (sort' g) (n - length g)
  where
    g  =  map (\x -> (head x, length x, 1)) $group $ sort s
    sort'  =  sortBy compare'
    compare' (_, a1, b1) (_, a2, b2)
        =  compare (b1 % a1) (b2 % a2)
    solve' g 0  =  Just (k, s)
      where
        s  =  concat [replicate m c | (c, _, m) <- g]
        k  =  maximum
            [(n-1) `div` m + 1 | (c, n, m) <- g]
    solve' ((c, n, m) : gs) k
        =  solve' (sort' ((c, n, m+1):gs)) (k-1)

print' :: Maybe (Int, String) -> IO ()
print' (Just (k, s))  =  print k >> putStrLn s
print' Nothing  =  print (-1)

main :: IO ()
main  =  liftM2 solve getLine readLn >>= print'

{-# LANGUAGE BangPatterns #-}

import Data.List

main = do
  cs <- getLine
  n <- readLn
  case solve n cs of
    Just (n,res) -> print n >> putStrLn res
    Nothing -> print $ -1

solve :: Int -> String -> Maybe (Int,String)
solve n cs
  | p 1000 = Just (res, take n $(do(l,c)<-lcs;replicate ((l+res-1)`quot`res)c)++repeat 'a')
  | otherwise = Nothing
   where
     lcs = [(length ds, head ds)|ds <- group (sort cs)]
     p x = sum[(l+x-1)`quot`x|(l,_)<-lcs] <= n
     res = lowerBound p 1 1000

lowerBound :: (Integral i) => (i -> Bool) -> i -> i -> i
lowerBound p low high = go low high
   where
     go !low !high
       | high <= low = high
       | p mid       = go low       mid
       | otherwise   = go (mid + 1) high
      where
        mid = (low + high) `quot` 2

import Data.List
import Debug.Trace

answer :: [Int] -> Int -> Int
answer l n
  | length l > n = -1
  | otherwise = binary_search 1 (sum l) pred where
    pred t =
      sum (getRequired l t) <= n

getRequired :: [Int] -> Int -> [Int]
getRequired l t = (map (\x -> div (x + (t - 1)) t) l)

binary_search :: Int -> Int -> (Int -> Bool) -> Int
binary_search low hi pred = trace (show low ++ " " ++ show hi) $ abcde low hi pred where
  abcde low hi pred
    | low >= hi = low
    | otherwise =
      let mid = div (low + hi) 2
      in if pred mid
         then binary_search low mid pred
         else binary_search (mid + 1) hi pred

main = do
  str <- getLine
  n <- (fmap read getLine) :: IO Int
  let sorted = sort str
  let groups = group sorted
  let counts = map length groups
  let a = answer counts n
  print a
  case a of
    -1 -> return ()
    _ -> do
      let letters = map head groups
      let required = getRequired counts a
      let output = foldr (++) [] $ map (\(l, c) -> replicate c l) $ zip letters required
      putStrLn $ output ++ (replicate (n - length output) 'a')

import Data.List

import Control.Monad
import Control.Arrow
main = do
    l <- getLine
    n <- fmap read getLine
    let (i,s) = solve l n
    print i
    when (i /= -1) $ putStrLn s

itof :: Int -> Double
itof= fromIntegral

solve :: String -> Int -> (Int,String)
solve l n | length l' > n = (-1,"")
          | otherwise     = (k,s)
    where
    l' = sort $ map (\l -> (-length l,head l)) $  group $ sort l
    s0 = map snd l'
    l0 = filter ((/=0).fst) $ map (first succ) l'
    s  = loop s0 l0
    x  = snd $ head l'
    l1 = map (negate.length) $ group $ sort l
    l2  = map (negate.length) $ group $ sort s
    k   = maximum $ zipWith (\ a b -> ceiling $ itof a / itof b) l1 l2
    loop s l | null l        = take n $ s++repeat x
             | length s == n = s
             | otherwise     =
                let ((i,c):ls) = l in
                    loop (c:s) $ if i == -1 then ls else (sort ((i+1,c):ls))

import Data.List

import Control.Monad
import Control.Arrow
main = do
    l <- getLine
    n <- fmap read getLine
    let (i,s) = solve l n
    print i
    when (i /= -1) $ putStrLn s

itof :: Int -> Double
itof= fromIntegral

solve :: String -> Int -> (Int,String)
solve l n | length l' > n = (-1,"")
          | otherwise     = (k,s)
    where
    l' = sort $ map (\l -> (-length l,head l)) $  group $ sort l
    s0 = map snd l'
    l0 = map (first pred) l'
    s  = loop s0 l0
    l1 = map (negate.length) $ group $ sort l
    l2  = map (negate.length) $ group $ sort s
    k   = maximum $ zipWith (\ a b -> ceiling $ itof a / itof b) l1 l2
    loop s l | length s == n = s
             | otherwise     =
                let ((i,c):ls) = l in
                    loop (c:s) $ if i == -1 then ls else (sort ((i+1,c):ls))

import Data.List

import Control.Monad
import Control.Arrow
main = do
    l <- getLine
    n <- fmap read getLine
    let (i,s) = solve l n
    print i
    when (i /= -1) $ putStrLn s

itof :: Int -> Double
itof= fromIntegral

solve :: String -> Int -> (Int,String)
solve l n | length l' > n = (-1,"")
          | otherwise     = (k,s)
    where
    l' = sort $ map (\l -> (-length l,head l)) $  group $ sort l
    s0 = map snd l'
    l0 = filter ((/=0).fst) $ map (first succ) l'
    s  = loop s0 l0
    l1 = map (negate.length) $ group $ sort l
    l2  = map (negate.length) $ group $ sort s
    k   = maximum $ zipWith (\ a b -> ceiling $ itof a / itof b) l1 l2
    loop s l | null l        = take n $ s++repeat 'a'
             | length s == n = s
             | otherwise     =
                let ((i,c):ls) = l in
                    loop (c:s) $ if i == -1 then ls else (sort ((i+1,c):ls))

import Data.List

import Control.Monad
import Control.Arrow
main = do
    l <- getLine
    n <- fmap read getLine
    let (i,s) = solve l n
    print i
    when (i /= -1) $ putStrLn s

itof :: Int -> Double
itof= fromIntegral

solve :: String -> Int -> (Int,String)
solve l n | not (can l' n n) = (-1,"")
          | otherwise        = (k,take n $s ++ repeat 'a')
    where
    l' = map length l0
    l0 = group $ sort l
    k = binSearch (can l' n) 1 n
    s = construct l0 n k

can :: [Int] -> Int -> Int -> Bool
can l n k = (<=n) $ sum $ map (\c -> ceiling (itof c / itof k)) l

binSearch f i j | i + 1 == j = if f i then i else j
                | f m        = binSearch f i m
                | otherwise  = binSearch f m j
    where
    m = (i+j) `div` 2

construct l n k = concat $ map (\l ->
    take (ceiling (itof (length l) / itof k)) l) l

{-# LANGUAGE BangPatterns #-}
import Data.List hiding (insert)

main = do
  cs <- getLine
  n <- readLn
  case solve n cs of
    Just (n,res) -> print n >> putStrLn res
    Nothing -> print $ -1

solve :: Int -> String -> Maybe (Int,String)
solve n cs = go (length lcs) $ fromList lcs
   where
     lcs = [(length ds, head ds)|ds <- group (sort cs)]
     go !cnt h@(Fork (l,c) hs)
       | cnt < n = go (cnt+1).mergePairs $ singleton (l`div`2,c) : singleton (l-l`div`2,c) : hs
       | cnt == n = Just (l, map snd (toList h))
       | otherwise = Nothing

data Heap a = Fork !a [Heap a] | Empty

singleton :: a -> Heap a
singleton x = Fork x []

isEmpty :: Heap a -> Bool
isEmpty Empty = True
isEmpty _ = False

insert :: Ord a => a -> Heap a -> Heap a
insert x h = merge (Fork x []) h

maxElem :: Heap a -> Maybe a
maxElem (Fork x _) = Just x
maxElem _ = Nothing

deleteMax :: Ord a => Heap a -> Maybe (Heap a)
deleteMax (Fork _ hs) = Just $ mergePairs hs
deleteMax _ = Nothing

deleteFindMax :: Ord a => Heap a -> Maybe (a, Heap a)
deleteFindMax (Fork x hs) = Just (x, mergePairs hs)
deleteFindMax _ = Nothing

merge :: Ord a => Heap a -> Heap a -> Heap a
merge hx@(Fork x _) hy@(Fork y _)
  | x >= y    = join hx hy
  | otherwise = join hy hx
 where
   join (Fork x hs) h = Fork x (h:hs)
merge Empty hy = hy
merge hx _ = hx

mergePairs :: Ord a => [Heap a] -> Heap a
mergePairs (x:y:hs) = merge (merge x y) (mergePairs hs)
mergePairs [x]      = x
mergePairs []       = Empty

fromList :: Ord a => [a] -> Heap a
fromList xs = mergePairs $ map singleton xs

toList :: Ord a => Heap a -> [a]
toList (Fork x hs) = x : toList (mergePairs hs)
toList Empty = []

import Data.List
import Debug.Trace

answer :: [Int] -> Int -> Int
answer l n
  | length l > n = -1
  | otherwise = binary_search 1 (sum l) pred where
    pred t =
      sum (getRequired l t) <= n

getRequired :: [Int] -> Int -> [Int]
getRequired l t = (map (\x -> div (x + (t - 1)) t) l)

binary_search :: Int -> Int -> (Int -> Bool) -> Int
binary_search low hi pred = trace (show low ++ " " ++ show hi) $ abcde low hi pred where
  abcde low hi pred
    | low >= hi = low
    | otherwise =
      let mid = div (low + hi) 2
      in if pred mid
         then binary_search low mid pred
         else binary_search (mid + 1) hi pred

main = do
  str <- getLine
  n <- fmap read getLine
  let sorted = sort str
  let groups = group sorted
  let counts = map length groups
  let a = answer counts n
  print a
  let letters = map head groups
  let required = getRequired counts a
  putStrLn $ foldr (++) [] $ map (\(l, c) -> replicate c l) $ zip letters required

import Data.List
import Debug.Trace

answer :: [Int] -> Int -> Int
answer l n
  | length l > n = -1
  | otherwise = binary_search 1 (sum l) pred where
    pred t =
      sum (getRequired l t) <= n

getRequired :: [Int] -> Int -> [Int]
getRequired l t = (map (\x -> div (x + (t - 1)) t) l)

binary_search :: Int -> Int -> (Int -> Bool) -> Int
binary_search low hi pred = trace (show low ++ " " ++ show hi) $ abcde low hi pred where
  abcde low hi pred
    | low >= hi = low
    | otherwise =
      let mid = div (low + hi) 2
      in if pred mid
         then binary_search low mid pred
         else binary_search (mid + 1) hi pred

main = do
  str <- getLine
  n <- (fmap read getLine) :: IO Int
  let sorted = sort str
  let groups = group sorted
  let counts = map length groups
  case "okurdzfdjodgyzlw" `isPrefixOf` str of
    True -> print counts
    _ -> return ()
  let a = answer counts n
  print a
  case a of
    -1 -> return ()
    _ -> do
      let letters = map head groups
      let required = getRequired counts a
      putStrLn $ foldr (++) [] $ map (\(l, c) -> replicate c l) $ zip letters required

import Data.List
import Debug.Trace

answer :: [Int] -> Int -> Int
answer l n
  | length l > n = -1
  | otherwise = binary_search 1 (sum l) pred where
    pred t =
      sum (getRequired l t) <= n

getRequired :: [Int] -> Int -> [Int]
getRequired l t = (map (\x -> div (x + (t - 1)) t) l)

binary_search :: Int -> Int -> (Int -> Bool) -> Int
binary_search low hi pred = trace (show low ++ " " ++ show hi) $ abcde low hi pred where
  abcde low hi pred
    | low >= hi = low
    | otherwise =
      let mid = div (low + hi) 2
      in if pred mid
         then binary_search low mid pred
         else binary_search (mid + 1) hi pred

main = do
  str <- getLine
  n <- fmap read getLine
  let sorted = sort str
  let groups = group sorted
  let counts = map length groups
  let a = answer counts n
  print a
  case a of
    -1 -> return ()
    _ -> do
      let letters = map head groups
      let required = getRequired counts a
      putStrLn $ foldr (++) [] $ map (\(l, c) -> replicate c l) $ zip letters required