You have decided to open a new school. You have already found $$$n$$$ teachers and $$$m$$$ groups of students. The $$$i$$$-th group of students consists of $$$k_i \geq 2$$$ students. You know age of each teacher and each student. The ages of teachers are $$$a_1, a_2, \ldots, a_n$$$ and the ages of students of the $$$i$$$-th group are $$$b_{i, 1}, b_{i, 2}, \ldots, b_{i, k_i}$$$.To start lessons you should assign the teacher to each group of students. Such assignment should satisfy the following requirements:  To each group exactly one teacher assigned.  To each teacher at most $$$1$$$ group of students assigned.  The average of students' ages in each group doesn't exceed the age of the teacher assigned to this group. The average of set $$$x_1, x_2, \ldots, x_k$$$ of $$$k$$$ integers is $$$\frac{x_1 + x_2 + \ldots + x_k}{k}$$$.Recently you have heard that one of the students will refuse to study in your school. After this, the size of one group will decrease by $$$1$$$ while all other groups will remain unchanged.You don't know who will refuse to study. For each student determine if you can start lessons in case of his refusal.Note, that it is not guaranteed that it is possible to start lessons before any refusal.

The first line contains a single integer $$$t$$$ ($$$1 \leq t \leq 1000$$$) — the number of test cases. The first line of each test case contains two integers $$$n$$$ and $$$m$$$ ($$$1 \leq m \leq n \leq 10^5$$$) — the number of teachers and the number of groups of students. The second line of each test case contains $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$ ($$$1 \leq a_i \leq 10^5$$$) — the ages of teachers. The next $$$2m$$$ lines contains descriptions of groups.  The first line of description of group contains a single integer $$$k_i$$$ ($$$2 \leq k_i \leq 10^5$$$) — the number of students in this group.  The second line of description of group contains $$$k_i$$$ integers $$$b_{i, 1}, b_{i, 2}, \ldots, b_{i, k_i}$$$ ($$$1 \leq b_{i, j} \leq 10^5$$$) — the ages of students of this group. It is guaranteed that the total sum of $$$n$$$ over all test cases doesn't exceed $$$10^5$$$ and that the total sum of $$$k_1 + k_2 + \ldots + k_m$$$ over all test cases doesn't exceed $$$2 \cdot 10^5$$$

For each test case output string of symbols $$$0$$$ and $$$1$$$ of length $$$k_1 + k_2 + \ldots + k_m$$$. The $$$i$$$-th symbol of this string should be equals $$$1$$$ if it is possible to start lessons in case of the $$$i$$$-th student refuse and it should be equals $$$0$$$ otherwise. Students are numbered by integers from $$$1$$$ to $$$k_1 + k_2 + \ldots + k_m$$$ in the order they appear in the input. Thus, students of the $$$1$$$-st group are numbered by integers $$$1$$$, $$$2$$$, $$$\ldots$$$, $$$k_1$$$, students of the $$$2$$$-nd group are numbered by integers $$$k_1 + 1$$$, $$$k_1 + 2$$$, $$$\ldots$$$, $$$k_1 + k_2$$$ and so on.

NoteIn the first test case there is one group of students with average age $$$\frac{25+16+37}{3}=26$$$ and one teacher with age $$$30$$$. There exists only one assignment that allows to start lessons.If the student with age $$$16$$$ will refuse to study, the average age of students in this group will become $$$\frac{25+37}{2}=31$$$ so there won't be any assignment that allows to start lessons.In the second test case it is impossible to start lessons initially. However, if the $$$3$$$-rd student with age $$$111$$$ will refuse to study, the average ages of groups will become $$$\frac{4 + 5}{2}=4.5$$$ and $$$\frac{11+11}{2} = 11$$$ correspondingly. Then it is possible to assing the first group to the first teacher and the second group to the third teacher.

{-# LANGUAGE DeriveFunctor #-}

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.Ratio
import Data.Semigroup (Min(..), getMin)
import qualified Data.Set as S

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

-- import Debug.Trace
traceShowId = id
traceShow _ = id

data BinTree a = BinLeaf a | BinNode a (BinTree a) (BinTree a)
  deriving (Show, Eq, Functor)
data IntervalTree a = IT (Int,  Int) (BinTree a)

binAnn (BinLeaf v) = v
binAnn (BinNode v _ _) = v

buildITree :: (Semigroup e, IArray a e) => a Int e -> IntervalTree e
buildITree a = let (l, r) = bounds a in IT (l, r) $ go l r
  where
    go l r =
      if l == r then BinLeaf (a!l)
      else
        let mid = (l + r) `div` 2
            lt = go l mid
            rt = go (mid + 1) r
        in BinNode (binAnn lt <> binAnn rt) lt rt

queryITree :: Semigroup e => Int -> Int -> IntervalTree e -> e
queryITree ql qr (IT (l, r) bt) = go l r bt
  where
    go _ _ (BinLeaf v) = v
    go l' r' (BinNode a lt rt)
      | ql > r' || qr < l' = error $ "Undefined behavior " ++ show (ql, qr, l', r')
      | ql <= l' && qr >= r' = a
      | qr <= m = la
      | ql > m = ra
      | otherwise = la <> ra
      where
        m = (l' + r') `div` 2
        la = go l' m lt
        ra = go (m + 1) r' rt

data Pos = E | L | O | R deriving (Show, Eq, Ord)

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    ta <- getInts n
    sg <- replicateM m $ (head <$>getInts 1) >>= getInts
    let ta' = take m $ sortOn negate ta
        teacherAges :: UArray Int Int
        teacherAges = listArray (1, m) ta'
        studentGroups :: Array Int [Int]
        studentGroups = listArray (1, m) sg
        groupInfos = amap (groupInfo<$>length<*>sum) studentGroups
        groupOrder :: UArray Int Int
        groupOrder = traceShowId $ listArray (1, m) $ sortOn
          (\i -> let (x, _, _) = groupInfos!i in negate x) [1..m]
        revOrder :: UArray Int Int
        revOrder = array (1, m) $ (\(x, y) -> (y, x)) <$> assocs groupOrder
        add pos f = if f then S.singleton pos else S.empty
        getPosSet i = Min k
           where
             k
               |  i < m && teacherAges!(i + 1) % 1 >= avg = R
               | teacherAges!i % 1 >= avg = O
               |  i > 1 && teacherAges!(i - 1) % 1 >= avg = L
               | otherwise = E
             (avg, _, _) = groupInfos!(groupOrder!i)
        posSets :: Array Int (Min Pos)
        posSets =  traceShowId $ listArray (1, m) [getPosSet i | i <- [1..m]]
        posTree = buildITree posSets
        goGrp :: Int -> SP Builder
        goGrp ri = let i = revOrder!ri in mconcat<$>(sequence $ goStu i<$>studentGroups!(groupOrder!i))
        goStu :: Int -> Int -> SP Builder
        goStu i a =
          let (_, len, s) = groupInfos!(groupOrder!i)
              avg' = traceShowId $ (s - a) % (len - 1)
              findPos l r
                | l == r = l
                | avg' <= avg = findPos (m + 1) r
                | otherwise = findPos l m
                where
                  m = (l + r) `div` 2
                  (avg, _, _) = traceShowId $ groupInfos!(groupOrder!m)
              i' = findPos 1 (m + 1)
          in if traceShow ("KK", i, i') $ avg' <= (teacherAges!(if i' > i then i' - 1 else i'))%1 && ok i i' then pure $ char7 '1'
             else pure $ char7 '0'
        checkPos p l r =  (p<=) $ getMin $ queryITree l r posTree
        ok i i' = traceShow ("See ", s, t) $ (s <= 1 || checkPos O 1 (s - 1))
            && okMid && (t > m || checkPos O t m)
          where
            s = min i i'
            t = if i' > i then i' else i + 1
            okMid
              | i == i' || i' == i + 1 = True
              | i' > i = checkPos L (i + 1) (i' - 1)
              | otherwise = checkPos R i' (i - 1)
    (<>char7 '\n')<$>mconcat<$> mapM goGrp [1..m]
  where
    groupInfo l s = (s % l, l, s)

type SP = State [P.ByteString]

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

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

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

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

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

{-# LANGUAGE DeriveFunctor #-}

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.Ratio
import qualified Data.Set as S

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

-- import Debug.Trace
traceShowId = id
traceShow _ = id

data BinTree a = BinLeaf a | BinNode a (BinTree a) (BinTree a)
  deriving (Show, Eq, Functor)
data IntervalTree a = IT (Int,  Int) (BinTree a)

binAnn (BinLeaf v) = v
binAnn (BinNode v _ _) = v

buildITree :: (Monoid e, IArray a e) => a Int e -> IntervalTree e
buildITree a = let (l, r) = bounds a in IT (l, r) $ go l r
  where
    go l r =
      if l == r then BinLeaf (a!l)
      else
        let mid = (l + r) `div` 2
            lt = go l mid
            rt = go (mid + 1) r
        in BinNode (binAnn lt <> binAnn rt) lt rt

queryITree :: Monoid e => Int -> Int -> IntervalTree e -> e
queryITree ql qr (IT (l, r) bt) = go l r bt
  where
    go _ _ (BinLeaf v) = v
    go l' r' (BinNode a lt rt)
      | ql > r' || qr < l' = mempty
      | ql <= l' && qr >= r' = a
      | qr <= m = la
      | ql > m = ra
      | otherwise = la <> ra
      where
        m = (l' + r') `div` 2
        la = go l' m lt
        ra = go (m + 1) r' rt

data Pos = L | R | O deriving (Show, Eq, Ord)
newtype PosSet = PS {unPS :: S.Set Pos} deriving (Show, Eq)

instance Semigroup PosSet where
  (PS a) <> (PS b) = PS $ S.intersection a b

instance Monoid PosSet where
  mempty = PS $ S.fromList [L, R, O]

type ITPos = IntervalTree PosSet

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    ta <- getInts n
    sg <- replicateM m $ (head <$>getInts 1) >>= getInts
    let ta' = take m $ sortOn negate ta
        teacherAges :: UArray Int Int
        teacherAges = listArray (1, m) ta'
        studentGroups :: Array Int [Int]
        studentGroups = listArray (1, m) sg
        groupInfos = amap (groupInfo<$>length<*>sum) studentGroups
        groupOrder :: UArray Int Int
        groupOrder = traceShowId $ listArray (1, m) $ sortOn
          (\i -> let (x, _, _) = groupInfos!i in negate x) [1..m]
        revOrder :: UArray Int Int
        revOrder = array (1, m) $ (\(x, y) -> (y, x)) <$> assocs groupOrder
        add pos f = if f then S.singleton pos else S.empty
        getPosSet i = PS $ (add L $ i > 1 && teacherAges!(i - 1) % 1 >= avg)
          <> (add O $ teacherAges!i % 1 >= avg)
          <> (add R $ i < m && teacherAges!(i + 1) % 1 >= avg)
          where (avg, _, _) = groupInfos!(groupOrder!i)
        posSets :: Array Int PosSet
        posSets = traceShowId $ listArray (1, m) [getPosSet i | i <- [1..m]]
        posTree = buildITree posSets
        goGrp :: Int -> SP Builder
        goGrp ri = let i = revOrder!ri in mconcat<$>(sequence $ goStu i<$>studentGroups!(groupOrder!i))
        goStu :: Int -> Int -> SP Builder
        goStu i a =
          let (_, len, s) = groupInfos!(groupOrder!i)
              avg' = traceShowId $ (s - a) % (len - 1)
              findPos l r
                | l == r = l
                | avg' <= avg = findPos (m + 1) r
                | otherwise = findPos l m
                where
                  m = (l + r) `div` 2
                  (avg, _, _) = traceShowId $ groupInfos!(groupOrder!m)
              i' = findPos 1 (m + 1)
          in if traceShow ("KK", i, i') $ avg' <= (teacherAges!(if i' > i then i' - 1 else i'))%1 && ok i i' then pure $ char7 '1'
             else pure $ char7 '0'
        checkPos p l r = S.member p $ unPS $ queryITree l r posTree
        ok i i' = traceShow ("See ", s, t) $ (s <= 1 || checkPos O 1 (s - 1))
            && okMid && (t > m || checkPos O t m)
          where
            s = min i i'
            t = if i' > i then i' else i + 1
            okMid
              | i == i' || i' == i + 1 = True
              | i' > i = checkPos L (i + 1) (i' - 1)
              | otherwise = checkPos R i' (i - 1)
    (<>char7 '\n')<$>mconcat<$> mapM goGrp [1..m]
  where
    groupInfo l s = (s % l, l, s)

type SP = State [P.ByteString]

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

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

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

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

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

{-# OPTIONS_GHC -msse4.2 #-} -- fast clz
import qualified Data.ByteString.Lazy.Char8 as P
import Data.ByteString.Builder
import qualified Data.ByteString.Builder.Prim as Prim
import System.IO
import Control.Monad.Trans.State
import Data.Maybe

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

log2 :: Int -> Int
log2 v = finiteBitSize v - 1 - countLeadingZeros v

data Sparse = Sparse (Int -> Int -> Int) !(Array Int (UArray Int Int))

-- | @query st li ri@ is the range-summary of [li, ri)
query :: Sparse -> Int -> Int -> Int
query (Sparse fun arr) li ri = let
  layer = log2 (ri - li)
  in  fun (arr ! layer ! li) (arr ! layer ! (ri - bit layer))

mkSparse :: (Int -> Int -> Int) -> UArray Int Int -> Sparse
mkSparse fun arr = let
  (li, ri) = bounds arr
  lastLayer = log2 (ri + 1 - li)
  step :: UArray Int Int -> Int -> UArray Int Int
  step larr k = let
    (lli, lri) = bounds larr
    in  listArray (lli, lri - k)
        $ zipWith fun (elems larr) (drop k $ elems larr)
  layers = scanl' step arr $ map bit [0 .. lastLayer - 1]
  in  Sparse fun $ listArray (0, lastLayer) layers

calcAve :: Int -> Int -> Int
calcAve num den = case  divMod num den  of
  (q, r) -> 2 * q + min r 1

binSearch :: (Int -> Bool) -> Int -> Int -> Int
{-# INLINE binSearch #-} -- specialize for known functions
binSearch fun = let
  go li ri = if  li == ri
    then  li
    else  let
    mi = li + div (ri - li) 2
    in  if  fun mi
    then  go li mi
    else  go (mi + 1) ri
  in  go

lowerBound :: UArray Int Int -> Int -> Int
lowerBound arr v = let
  (li, ri) = bounds arr
  in  binSearch (\i -> arr ! i >= v) li (ri + 1)

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    a <- getInts n
    bLi <- replicateM m $ do
      ~[ki] <- getInts 1
      getInts ki
    let
      sa :: UArray Int Int
      sa = listArray (1, m) $ map (* 2) $ drop (n - m) $ sort a
      b :: Array Int [Int]
      b = listArray (1, m) bLi
      sizes :: UArray Int Int
      sizes = listArray (1, m) $ map length $ elems b
      tots :: UArray Int Int
      tots = listArray (1, m) $ map (foldl' (+) 0) $ elems b
      groupAves :: UArray Int Int
      groupAves = listArray (1, m)
        $ sort $ zipWith calcAve (elems tots) (elems sizes)

      d0 = listArray (1, m)   $ zipWith (-) (elems sa) (elems groupAves)
      dL = listArray (1, m-1) $ zipWith (-) (elems sa) (tail $ elems groupAves)
      dR = listArray (2, m)   $ zipWith (-) (tail $ elems sa) (elems groupAves)
      q0 = mkSparse min d0
      qL = mkSparse min dL
      qR = mkSparse min dR

      ok q li ri = li >= ri || query q li ri >= 0

      solve :: Int -> Int -> Int
      solve ix toOust = let
        oldTot = tots ! ix
        oldSize = sizes ! ix
        oldAve = calcAve oldTot oldSize
        newAve = calcAve (oldTot - toOust) (oldSize - 1)
        oldPos = lowerBound groupAves oldAve
        newPos = lowerBound groupAves newAve
        in  if  newPos <= oldPos
        then  let
          v1 = ok q0 1 newPos
          v2 = newAve <= sa ! newPos
          v3 = ok qR (newPos + 1) (oldPos + 1)
          v4 = ok q0 (oldPos + 1) (m + 1)
          in  bool 0 1 $ v1 && v2 && v3 && v4
        else  let
          realNewPos = newPos - 1 -- don't count your removed old self
          v1 = ok q0 1 oldPos
          v2 = ok qL oldPos realNewPos
          v3 = newAve <= sa ! realNewPos
          v4 = ok q0 (realNewPos + 1) (m + 1)
          in  bool 0 1 $ v1 && v2 && v3 && v4
      solveG :: Int -> Builder
      solveG i = Prim.primMapListBounded Prim.intDec [solve i v | v <- b ! i]
    pure $ foldMap solveG [1..m] <> char7 '\n'

type SP = State [P.ByteString]

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

getInts :: Int -> SP [Int]
getInts k = map (fst . fromJust . P.readInt) <$> getNext k
{-
putInts :: [Int] -> Builder
putInts vs = let
  sepPrim = (,) ' ' Prim.>$<
    Prim.liftFixedToBounded Prim.char7 Prim.>*< Prim.intDec
  in  case  vs  of
  [] -> char7 '\n'
  x : xs -> intDec x <> Prim.primMapListBounded sepPrim xs <> char7 '\n'
-}
main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  inp <- P.getContents
  let  outp = evalState mainFun $ P.words inp
  P.putStr $ toLazyByteString outp

{-# LANGUAGE DeriveFunctor #-}

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.Ratio
import Data.Semigroup (Min(..), getMin)
import qualified Data.Set as S

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

-- import Debug.Trace
traceShowId = id
traceShow _ = id

data BinTree a = BinLeaf a | BinNode a (BinTree a) (BinTree a)
  deriving (Show, Eq, Functor)
data IntervalTree a = IT (Int,  Int) (BinTree a)

binAnn (BinLeaf v) = v
binAnn (BinNode v _ _) = v

buildITree :: (Semigroup e, IArray a e) => a Int e -> IntervalTree e
buildITree a = let (l, r) = bounds a in IT (l, r) $ go l r
  where
    go l r =
      if l == r then BinLeaf (a!l)
      else
        let mid = (l + r) `div` 2
            lt = go l mid
            rt = go (mid + 1) r
        in BinNode (binAnn lt <> binAnn rt) lt rt

queryITree :: Semigroup e => Int -> Int -> IntervalTree e -> e
queryITree ql qr (IT (l, r) bt) = go l r bt
  where
    go _ _ (BinLeaf v) = v
    go l' r' (BinNode a lt rt)
      | ql > r' || qr < l' = error $ "Undefined behavior " ++ show (ql, qr, l', r')
      | ql <= l' && qr >= r' = a
      | qr <= m = la
      | ql > m = ra
      | otherwise = la <> ra
      where
        m = (l' + r') `div` 2
        la = go l' m lt
        ra = go (m + 1) r' rt

data Pos = E | L | O | R deriving (Show, Eq, Ord)

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    ta <- getInts n
    sg <- replicateM m $ (head <$>getInts 1) >>= getInts
    let ta' = take m $ sortOn negate ta
        teacherAges :: UArray Int Int
        teacherAges = listArray (1, m) ta'
        studentGroups :: Array Int [Int]
        studentGroups = listArray (1, m) sg
        groupInfos = amap (groupInfo<$>length<*>sum) studentGroups
        groupOrder :: UArray Int Int
        groupOrder = traceShowId $ listArray (1, m) $ sortOn
          (\i -> let (x, _, _) = groupInfos!i in negate x) [1..m]
        revOrder :: UArray Int Int
        revOrder = array (1, m) $ (\(x, y) -> (y, x)) <$> assocs groupOrder
        add pos f = if f then S.singleton pos else S.empty
        getPosSet i = Min k
           where
             k
               |  i >= m || teacherAges!(i + 1) % 1 >= avg = R
               | teacherAges!i % 1 >= avg = O
               |  i <= 1 || teacherAges!(i - 1) % 1 >= avg = L
               | otherwise = E
             (avg, _, _) = groupInfos!(groupOrder!i)
        posSets :: Array Int (Min Pos)
        posSets =  traceShowId $ listArray (1, m) [getPosSet i | i <- [1..m]]
        posTree = buildITree posSets
        goGrp :: Int -> SP Builder
        goGrp ri = let i = revOrder!ri in mconcat<$>(sequence $ goStu i<$>studentGroups!(groupOrder!i))
        goStu :: Int -> Int -> SP Builder
        goStu i a =
          let (_, len, s) = groupInfos!(groupOrder!i)
              avg' = traceShowId $ (s - a) % (len - 1)
              findPos l r
                | l == r = l
                | avg' <= avg = findPos (m + 1) r
                | otherwise = findPos l m
                where
                  m = (l + r) `div` 2
                  (avg, _, _) = traceShowId $ groupInfos!(groupOrder!m)
              i' = findPos 1 (m + 1)
          in if traceShow ("KK", i, i') $ avg' <= (teacherAges!(if i' > i then i' - 1 else i'))%1 && ok i i' then pure $ char7 '1'
             else pure $ char7 '0'
        checkPos p l r =  (p<=) $ getMin $ queryITree l r posTree
        ok i i' = traceShow ("See ", s, t) $ (s <= 1 || checkPos O 1 (s - 1))
            && okMid && (t > m || checkPos O t m)
          where
            s = min i i'
            t = if i' > i then i' else i + 1
            okMid
              | i == i' || i' == i + 1 = True
              | i' > i = checkPos L (i + 1) (i' - 1)
              | otherwise = checkPos R i' (i - 1)
    (<>char7 '\n')<$>mconcat<$> mapM goGrp [1..m]
  where
    groupInfo l s = (s % l, l, s)

type SP = State [P.ByteString]

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

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

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

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

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

{-# LANGUAGE DeriveFunctor #-}

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.Ratio
import qualified Data.Set as S

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

-- import Debug.Trace
traceShowId = id
traceShow _ = id

data BinTree a = BinLeaf a | BinNode a (BinTree a) (BinTree a)
  deriving (Show, Eq, Functor)
data IntervalTree a = IT (Int,  Int) (BinTree a)

binAnn (BinLeaf v) = v
binAnn (BinNode v _ _) = v

buildITree :: (Monoid e, IArray a e) => a Int e -> IntervalTree e
buildITree a = let (l, r) = bounds a in IT (l, r) $ go l r
  where
    go l r =
      if l == r then BinLeaf (a!l)
      else
        let mid = (l + r) `div` 2
            lt = go l mid
            rt = go (mid + 1) r
        in BinNode (binAnn lt <> binAnn rt) lt rt

queryITree :: Monoid e => Int -> Int -> IntervalTree e -> e
queryITree ql qr (IT (l, r) bt) = go l r bt
  where
    go _ _ (BinLeaf v) = v
    go l' r' (BinNode a lt rt)
      | ql > r' || qr < l' = mempty
      | ql <= l' && qr >= r' = a
      | qr <= m = la
      | ql > m = ra
      | otherwise = la <> ra
      where
        m = (l' + r') `div` 2
        la = go l m lt
        ra = go (m + 1) r rt

data Pos = L | R | O deriving (Show, Eq, Ord)
newtype PosSet = PS {unPS :: S.Set Pos} deriving (Show, Eq)

instance Semigroup PosSet where
  (PS a) <> (PS b) = PS $ S.intersection a b

instance Monoid PosSet where
  mempty = PS $ S.fromList [L, R, O]

type ITPos = IntervalTree PosSet

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    ta <- getInts n
    sg <- replicateM m $ (head <$>getInts 1) >>= getInts
    let ta' = take m $ sortOn negate ta
        teacherAges :: UArray Int Int
        teacherAges = listArray (1, m) ta'
        studentGroups :: Array Int [Int]
        studentGroups = listArray (1, m) sg
        groupInfos = amap (groupInfo<$>length<*>sum) studentGroups
        groupOrder :: UArray Int Int
        groupOrder = traceShowId $ listArray (1, m) $ sortOn
          (\i -> let (x, _, _) = groupInfos!i in negate x) [1..m]
        revOrder :: UArray Int Int
        revOrder = array (1, m) $ (\(x, y) -> (y, x)) <$> assocs groupOrder
        add pos f = if f then S.singleton pos else S.empty
        getPosSet i = PS $ (add L $ i > 1 && teacherAges!(i - 1) % 1 >= avg)
          <> (add O $ teacherAges!i % 1 >= avg)
          <> (add R $ i < m && teacherAges!(i + 1) % 1 >= avg)
          where (avg, _, _) = groupInfos!(groupOrder!i)
        posSets :: Array Int PosSet
        posSets = traceShowId $ listArray (1, m) [getPosSet i | i <- [1..m]]
        posTree = buildITree posSets
        goGrp :: Int -> SP Builder
        goGrp ri = let i = revOrder!ri in mconcat<$>(sequence $ goStu i<$>studentGroups!(groupOrder!i))
        goStu :: Int -> Int -> SP Builder
        goStu i a =
          let (_, len, s) = groupInfos!(groupOrder!i)
              avg' = traceShowId $ (s - a) % (len - 1)
              findPos l r
                | l == r = l
                | avg' <= avg = findPos (m + 1) r
                | otherwise = findPos l m
                where
                  m = (l + r) `div` 2
                  (avg, _, _) = traceShowId $ groupInfos!(groupOrder!m)
              i' = findPos 1 (m + 1)
          in if traceShow ("KK", i, i') $ avg' <= (teacherAges!(if i' > i then i' - 1 else i'))%1 && ok i i' then pure $ char7 '1'
             else pure $ char7 '0'
        checkPos p l r = S.member p $ unPS $ queryITree l r posTree
        ok i i' = traceShow ("See ", s, t) $ (s <= 1 || checkPos O 1 (s - 1))
            && okMid && (t > m || checkPos O t m)
          where
            s = min i i'
            t = if i' > i then i' else i + 1
            okMid
              | i == i' || i' == i + 1 = True
              | i' > i = checkPos L (i + 1) (i' - 1)
              | otherwise = checkPos R i' (i - 1)
    (<>char7 '\n')<$>mconcat<$> mapM goGrp [1..m]
  where
    groupInfo l s = (s % l, l, s)

type SP = State [P.ByteString]

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

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

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

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

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

{-# LANGUAGE DeriveFunctor #-}

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.Ratio
import qualified Data.Set as S

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

-- import Debug.Trace
traceShowId = id
traceShow _ = id

data BinTree a = BinLeaf a | BinNode a (BinTree a) (BinTree a)
  deriving (Show, Eq, Functor)
data IntervalTree a = IT (Int,  Int) (BinTree a)

binAnn (BinLeaf v) = v
binAnn (BinNode v _ _) = v

buildITree :: (Monoid e, IArray a e) => a Int e -> IntervalTree e
buildITree a = let (l, r) = bounds a in IT (l, r) $ go l r
  where
    go l r =
      if l == r then BinLeaf (a!l)
      else
        let mid = (l + r) `div` 2
            lt = go l mid
            rt = go (mid + 1) r
        in BinNode (binAnn lt <> binAnn rt) lt rt

queryITree :: Monoid e => Int -> Int -> IntervalTree e -> e
queryITree ql qr (IT (l, r) bt) = go l r bt
  where
    go _ _ (BinLeaf v) = v
    go l' r' (BinNode a lt rt)
      | ql > r' || qr < l' = mempty
      | ql <= l' && qr >= r' = a
      | qr <= m = la
      | ql > m = ra
      | otherwise = la <> ra
      where
        m = (l' + r') `div` 2
        la = go l m lt
        ra = go (m + 1) r rt

data Pos = L | R | O deriving (Show, Eq, Ord)
newtype PosSet = PS {unPS :: S.Set Pos} deriving (Show, Eq)

instance Semigroup PosSet where
  (PS a) <> (PS b) = PS $ S.intersection a b

instance Monoid PosSet where
  mempty = PS $ S.fromList [L, R, O]

type ITPos = IntervalTree PosSet

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    ta <- getInts n
    sg <- replicateM m $ (head <$>getInts 1) >>= getInts
    let ta' = take m $ sortOn negate ta
        teacherAges :: UArray Int Int
        teacherAges = listArray (1, m) ta'
        studentGroups :: Array Int [Int]
        studentGroups = listArray (1, m) sg
        groupInfos = amap (groupInfo<$>length<*>sum) studentGroups
        groupOrder :: UArray Int Int
        groupOrder = traceShowId $ listArray (1, m) $ sortOn
          (\i -> let (x, _, _) = groupInfos!i in negate x) [1..m]
        revOrder :: UArray Int Int
        revOrder = array (1, m) $ (\(x, y) -> (y, x)) <$> assocs groupOrder
        add pos f = if f then S.singleton pos else S.empty
        getPosSet i = PS $ (add L $ i > 1 && teacherAges!(i - 1) % 1 >= avg)
          <> (add O $ teacherAges!i % 1 >= avg)
          <> (add R $ i < m && teacherAges!(i + 1) % 1 >= avg)
          where (avg, _, _) = groupInfos!(groupOrder!i)
        posSets :: Array Int PosSet
        posSets = traceShowId $ listArray (1, m) [getPosSet i | i <- [1..m]]
        posTree = buildITree posSets
        goGrp :: Int -> SP Builder
        goGrp ri = let i = revOrder!ri in mconcat<$>(sequence $ goStu i<$>studentGroups!(groupOrder!i))
        goStu :: Int -> Int -> SP Builder
        goStu i a =
          let (_, len, s) = groupInfos!(groupOrder!i)
              avg' = traceShowId $ (s - a) % (len - 1)
              findPos l r
                | l == r = l
                | avg' <= avg = findPos (m + 1) r
                | otherwise = findPos l m
                where
                  m = (l + r) `div` 2
                  (avg, _, _) = traceShowId $ groupInfos!(groupOrder!m)
              i' = findPos 1 (m + 1)
          in if traceShow ("KK", i, i') $ avg' <= (teacherAges!(if i' > i then i' - 1 else i'))%1 && ok i i' then pure $ char7 '1'
             else pure $ char7 '0'
        checkPos p l r = S.member p $ unPS $ queryITree l r posTree
        ok i i' = traceShow ("See ", s, t) $ (s <= 1 || checkPos O 1 (s - 1))
            && okMid d s t
            && (t > m || checkPos O t m)
          where
            s = min i i'
            t = if i' > i then i' else i + 1
            d
              | i' == i + 1 || i' == i = O
              | i' > i = R
              | otherwise = L
        okMid O _ _ = True
        okMid L l r = checkPos R l (r - 1)
        okMid R l r = checkPos L (l + 1) (r - 1)
    (<>char7 '\n')<$>mconcat<$> mapM goGrp [1..m]
  where
    groupInfo l s = (s % l, l, s)

type SP = State [P.ByteString]

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

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

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

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

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

{-# LANGUAGE DeriveFunctor #-}

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.Ratio
import qualified Data.Set as S

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

-- import Debug.Trace
traceShowId = id
traceShow _ = id

data BinTree a = BinLeaf a | BinNode a (BinTree a) (BinTree a)
  deriving (Show, Eq, Functor)
data IntervalTree a = IT (Int,  Int) (BinTree a)

binAnn (BinLeaf v) = v
binAnn (BinNode v _ _) = v

buildITree :: (Monoid e, IArray a e) => a Int e -> IntervalTree e
buildITree a = let (l, r) = bounds a in IT (l, r) $ go l r
  where
    go l r =
      if l == r then BinLeaf (a!l)
      else
        let mid = (l + r) `div` 2
            lt = go l mid
            rt = go (mid + 1) r
        in BinNode (binAnn lt <> binAnn rt) lt rt

queryITree :: Monoid e => Int -> Int -> IntervalTree e -> e
queryITree ql qr (IT (l, r) bt) = go l r bt
  where
    go _ _ (BinLeaf v) = v
    go l' r' (BinNode a lt rt)
      | ql > r' || qr < l' = mempty
      | ql <= l' && qr >= r' = a
      | qr <= m = la
      | ql > m = ra
      | otherwise = la <> ra
      where
        m = (l' + r') `div` 2
        la = go l m lt
        ra = go (m + 1) r rt

data Pos = L | R | O deriving (Show, Eq, Ord)
newtype PosSet = PS {unPS :: S.Set Pos} deriving (Show, Eq)

instance Semigroup PosSet where
  (PS a) <> (PS b) = PS $ S.intersection a b

instance Monoid PosSet where
  mempty = PS $ S.fromList [L, R, O]

type ITPos = IntervalTree PosSet

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    ta <- getInts n
    sg <- replicateM m $ (head <$>getInts 1) >>= getInts
    let ta' = take m $ sortOn negate ta
        teacherAges :: UArray Int Int
        teacherAges = listArray (1, m) ta'
        studentGroups :: Array Int [Int]
        studentGroups = listArray (1, m) sg
        groupInfos = amap (groupInfo<$>length<*>sum) studentGroups
        groupOrder :: UArray Int Int
        groupOrder = traceShowId $ listArray (1, m) $ sortOn
          (\i -> let (x, _, _) = groupInfos!i in negate x) [1..m]
        revOrder :: UArray Int Int
        revOrder = array (1, m) $ (\(x, y) -> (y, x)) <$> assocs groupOrder
        add pos f = if f then S.singleton pos else S.empty
        getPosSet i = PS $ (add L $ i > 1 && teacherAges!(i - 1) % 1 >= avg)
          <> (add O $ teacherAges!i % 1 >= avg)
          <> (add R $ i < m && teacherAges!(i + 1) % 1 >= avg)
          where (avg, _, _) = groupInfos!(groupOrder!i)
        posSets :: Array Int PosSet
        posSets = traceShowId $ listArray (1, m) [getPosSet i | i <- [1..m]]
        posTree = buildITree posSets
        goGrp :: Int -> SP Builder
        goGrp ri = let i = revOrder!ri in mconcat<$>(sequence $ goStu i<$>studentGroups!(groupOrder!i))
        goStu :: Int -> Int -> SP Builder
        goStu i a =
          let (_, len, s) = groupInfos!(groupOrder!i)
              avg' = traceShowId $ (s - a) % (len - 1)
              findPos l r
                | l == r = l
                | avg' <= avg = findPos (m + 1) r
                | otherwise = findPos l m
                where
                  m = (l + r) `div` 2
                  (avg, _, _) = traceShowId $ groupInfos!(groupOrder!m)
              i' = findPos 1 (m + 1)
          in if traceShow ("KK", i, i') $ avg' <= (teacherAges!(if i' > i then i' - 1 else i'))%1 && ok i i' then pure $ char7 '1'
             else pure $ char7 '0'
        checkPos p l r = S.member p $ unPS $ queryITree l r posTree
        ok i i' = traceShow ("See ", s, t) $ (s <= 1 || checkPos O 1 (s - 1))
            && okMid d s t
            && (t <= m || checkPos O t m)
          where
            s = min i i'
            t = if i' > i then i' else i + 1
            d
              | i' == i + 1 || i' == i = O
              | i' > i = R
              | otherwise = L
        okMid O _ _ = True
        okMid L l r = checkPos R l (r - 1)
        okMid R l r = checkPos L (l + 1) (r - 1)
    (<>char7 '\n')<$>mconcat<$> mapM goGrp [1..m]
  where
    groupInfo l s = (s % l, l, s)

type SP = State [P.ByteString]

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

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

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

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

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

{-# LANGUAGE DeriveFunctor #-}

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.Ratio
import qualified Data.Set as S

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

-- import Debug.Trace
traceShowId = id
traceShow _ = id

data BinTree a = BinLeaf a | BinNode a (BinTree a) (BinTree a)
  deriving (Show, Eq, Functor)
data IntervalTree a = IT (Int,  Int) (BinTree a)

binAnn (BinLeaf v) = v
binAnn (BinNode v _ _) = v

buildITree :: (Monoid e, IArray a e) => a Int e -> IntervalTree e
buildITree a = let (l, r) = bounds a in IT (l, r) $ go l r
  where
    go l r =
      if l == r then BinLeaf (a!l)
      else
        let mid = (l + r) `div` 2
            lt = go l mid
            rt = go (mid + 1) r
        in BinNode (binAnn lt <> binAnn rt) lt rt

queryITree :: Monoid e => Int -> Int -> IntervalTree e -> e
queryITree ql qr (IT (l, r) bt) = go l r bt
  where
    go _ _ (BinLeaf v) = v
    go l' r' (BinNode a lt rt)
      | ql > r' || qr < l' = mempty
      | ql <= l' && qr >= r' = a
      | qr <= m = la
      | ql > m = ra
      | otherwise = la <> ra
      where
        m = (l' + r') `div` 2
        la = go l m lt
        ra = go (m + 1) r rt

data Pos = L | R | O deriving (Show, Eq, Ord)
newtype PosSet = PS {unPS :: S.Set Pos} deriving (Show, Eq)

instance Semigroup PosSet where
  (PS a) <> (PS b) = PS $ S.intersection a b

instance Monoid PosSet where
  mempty = PS $ S.fromList [L, R, O]

type ITPos = IntervalTree PosSet

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    ta <- getInts n
    sg <- replicateM m $ (head <$>getInts 1) >>= getInts
    let ta' = take m $ sortOn negate ta
        teacherAges :: UArray Int Int
        teacherAges = listArray (1, m) ta'
        studentGroups :: Array Int [Int]
        studentGroups = listArray (1, m) sg
        groupInfos = amap (groupInfo<$>length<*>sum) studentGroups
        groupOrder :: UArray Int Int
        groupOrder = traceShowId $ listArray (1, m) $ sortOn
          (\i -> let (x, _, _) = groupInfos!i in negate x) [1..m]
        revOrder :: UArray Int Int
        revOrder = array (1, m) $ (\(x, y) -> (y, x)) <$> assocs groupOrder
        add pos f = if f then S.singleton pos else S.empty
        getPosSet i = PS $ (add L $ i > 1 && teacherAges!(i - 1) % 1 >= avg)
          <> (add O $ teacherAges!i % 1 >= avg)
          <> (add R $ i < m && teacherAges!(i + 1) % 1 >= avg)
          where (avg, _, _) = groupInfos!(groupOrder!i)
        posSets :: Array Int PosSet
        posSets = traceShowId $ listArray (1, m) [getPosSet i | i <- [1..m]]
        posTree = buildITree posSets
        goGrp :: Int -> SP Builder
        goGrp ri = let i = revOrder!ri in mconcat<$>(sequence $ goStu i<$>studentGroups!(groupOrder!i))
        goStu :: Int -> Int -> SP Builder
        goStu i a =
          let (_, len, s) = groupInfos!(groupOrder!i)
              avg' = traceShowId $ (s - a) % (len - 1)
              findPos l r
                | l == r  = l
                | avg' <= avg = findPos (m + 1) r
                | otherwise = findPos l m
                where
                  m = (l + r) `div` 2
                  (avg, _, _) = traceShowId $ groupInfos!(groupOrder!m)
              i' = findPos 1 (m + 1)
          in if traceShow ("KK", i, i') $ avg' <= (teacherAges!(if i' > i then i' - 1 else i'))%1 && ok i i' then pure $ char7 '1'
             else pure $ char7 '0'
        checkPos p l r = S.member p $ unPS $ queryITree l r posTree
        ok i i' = traceShow ("See ", s, t) $ (s <= 1 || checkPos O 1 (s - 1))
            && okMid d s t
            && (checkPos O (if i' > i then i' else i + 1) m)
          where
            s = min i i'
            d
              | i' == i + 1 || i' == i = O
              | i' > i = R
              | otherwise = L
        okMid O _ _ = True
        okMid L l r = checkPos R l (r - 1)
        okMid R l r = checkPos L (l + 1) (r - 1)
    (<>char7 '\n')<$>mconcat<$> mapM goGrp [1..m]
  where
    groupInfo l s = (s % l, l, s)

type SP = State [P.ByteString]

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

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

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

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

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

{-# LANGUAGE DeriveFunctor #-}

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.Ratio
import qualified Data.Set as S

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

-- import Debug.Trace
traceShowId = id
traceShow _ = id

data BinTree a = BinLeaf a | BinNode a (BinTree a) (BinTree a)
  deriving (Show, Eq, Functor)
data IntervalTree a = IT (Int,  Int) (BinTree a)

binAnn (BinLeaf v) = v
binAnn (BinNode v _ _) = v

buildITree :: (Monoid e, IArray a e) => a Int e -> IntervalTree e
buildITree a = let (l, r) = bounds a in IT (l, r) $ go l r
  where
    go l r =
      if l == r then BinLeaf (a!l)
      else
        let mid = (l + r) `div` 2
            lt = go l mid
            rt = go (mid + 1) r
        in BinNode (binAnn lt <> binAnn rt) lt rt

queryITree :: Monoid e => Int -> Int -> IntervalTree e -> e
queryITree ql qr (IT (l, r) bt) = go l r bt
  where
    go _ _ (BinLeaf v) = v
    go l' r' (BinNode a lt rt)
      | ql > r' || qr < l' = mempty
      | ql <= l' && qr >= r' = a
      | qr <= m = la
      | ql > m = ra
      | otherwise = la <> ra
      where
        m = (l' + r') `div` 2
        la = go l m lt
        ra = go (m + 1) r rt

data Pos = L | R | O deriving (Show, Eq, Ord)
newtype PosSet = PS {unPS :: S.Set Pos} deriving (Show, Eq)

instance Semigroup PosSet where
  (PS a) <> (PS b) = PS $ S.intersection a b

instance Monoid PosSet where
  mempty = PS $ S.fromList [L, R, O]

type ITPos = IntervalTree PosSet

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    ta <- getInts n
    sg <- replicateM m $ (head <$>getInts 1) >>= getInts
    let ta' = take m $ sortOn negate ta
        teacherAges :: UArray Int Int
        teacherAges = listArray (1, m) ta'
        studentGroups :: Array Int [Int]
        studentGroups = listArray (1, m) sg
        groupInfos = amap (groupInfo<$>length<*>sum) studentGroups
        groupOrder :: UArray Int Int
        groupOrder = traceShowId $ listArray (1, m) $ sortOn
          (\i -> let (x, _, _) = groupInfos!i in negate x) [1..m]
        revOrder :: UArray Int Int
        revOrder = array (1, m) $ (\(x, y) -> (y, x)) <$> assocs groupOrder
        add pos f = if f then S.singleton pos else S.empty
        getPosSet i = PS $ (add L $ i > 1 && teacherAges!(i - 1) % 1 >= avg)
          <> (add O $ teacherAges!i % 1 >= avg)
          <> (add R $ i < m && teacherAges!(i + 1) % 1 >= avg)
          where (avg, _, _) = groupInfos!(groupOrder!i)
        posSets :: Array Int PosSet
        posSets = traceShowId $ listArray (1, m) [getPosSet i | i <- [1..m]]
        posTree = buildITree posSets
        goGrp :: Int -> SP Builder
        goGrp ri = let i = revOrder!ri in mconcat<$>(sequence $ goStu i<$>studentGroups!(groupOrder!i))
        goStu :: Int -> Int -> SP Builder
        goStu i a =
          let (_, len, s) = groupInfos!(groupOrder!i)
              avg' = traceShowId $ (s - a) % (len - 1)
              findPos l r
                | l == r  = l
                | avg' <= avg = findPos (m + 1) r
                | otherwise = findPos l m
                where
                  m = (l + r) `div` 2
                  (avg, _, _) = traceShowId $ groupInfos!(groupOrder!m)
              i' = findPos 1 (m + 1)
          in if traceShow ("KK", i, i') $ avg' <= (teacherAges!(if i' > i then i' - 1 else i'))%1 && ok i i' then pure $ char7 '1'
             else pure $ char7 '0'
        checkPos p l r = S.member p $ unPS $ queryITree l r posTree
        ok i i' = traceShow ("See ", s, t) $ (s <= 1 || checkPos O 1 (s - 1))
            && okMid d s t
            && (t > m || checkPos O t m)
          where
            s = min i i'
            t = max i i'
            d
              | i' == i + 1 || i' == i = O
              | i' > i = R
              | otherwise = L
        okMid O _ _ = True
        okMid L l r = checkPos R l (r - 1)
        okMid R l r = checkPos L (l + 1) (r - 1)
    (<>char7 '\n')<$>mconcat<$> mapM goGrp [1..m]
  where
    groupInfo l s = (s % l, l, s)

type SP = State [P.ByteString]

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

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

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

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

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

{-# LANGUAGE DeriveFunctor #-}

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.Ratio
import qualified Data.Set as S

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

-- import Debug.Trace
traceShowId = id
traceShow _ = id

data BinTree a = BinLeaf a | BinNode a (BinTree a) (BinTree a)
  deriving (Show, Eq, Functor)
data IntervalTree a = IT (Int,  Int) (BinTree a)

binAnn (BinLeaf v) = v
binAnn (BinNode v _ _) = v

buildITree :: (Monoid e, IArray a e) => a Int e -> IntervalTree e
buildITree a = let (l, r) = bounds a in IT (l, r) $ go l r
  where
    go l r =
      if l == r then BinLeaf (a!l)
      else
        let mid = (l + r) `div` 2
            lt = go l mid
            rt = go (mid + 1) r
        in BinNode (binAnn lt <> binAnn rt) lt rt

queryITree :: Monoid e => Int -> Int -> IntervalTree e -> e
queryITree ql qr (IT (l, r) bt) = go l r bt
  where
    go _ _ (BinLeaf v) = v
    go l' r' (BinNode a lt rt)
      | ql > r' || qr < l' = mempty
      | ql <= l' && qr >= r' = a
      | qr <= m = la
      | ql > m = ra
      | otherwise = la <> ra
      where
        m = (l' + r') `div` 2
        la = go l m lt
        ra = go (m + 1) r rt

data Pos = L | R | O deriving (Show, Eq, Ord)
newtype PosSet = PS {unPS :: S.Set Pos} deriving (Show, Eq)

instance Semigroup PosSet where
  (PS a) <> (PS b) = PS $ S.intersection a b

instance Monoid PosSet where
  mempty = PS $ S.fromList [L, R, O]

type ITPos = IntervalTree PosSet

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    ta <- getInts n
    sg <- replicateM m $ (head <$>getInts 1) >>= getInts
    let ta' = take m $ sortOn negate ta
        teacherAges :: UArray Int Int
        teacherAges = listArray (1, m) ta'
        studentGroups :: Array Int [Int]
        studentGroups = listArray (1, m) sg
        groupInfos = amap (groupInfo<$>length<*>sum) studentGroups
        groupOrder :: UArray Int Int
        groupOrder = traceShowId $ listArray (1, m) $ sortOn
          (\i -> let (x, _, _) = groupInfos!i in negate x) [1..m]
        revOrder :: UArray Int Int
        revOrder = array (1, m) $ (\(x, y) -> (y, x)) <$> assocs groupOrder
        add pos f = if f then S.singleton pos else S.empty
        getPosSet i = PS $ (add L $ i > 1 && teacherAges!(i - 1) % 1 >= avg)
          <> (add O $ teacherAges!i % 1 >= avg)
          <> (add R $ i < m && teacherAges!(i + 1) % 1 >= avg)
          where (avg, _, _) = groupInfos!(groupOrder!i)
        posSets :: Array Int PosSet
        posSets = traceShowId $ listArray (1, m) [getPosSet i | i <- [1..m]]
        posTree = buildITree posSets
        goGrp :: Int -> SP Builder
        goGrp ri = let i = revOrder!ri in mconcat<$>(sequence $ goStu i<$>studentGroups!(groupOrder!i))
        goStu :: Int -> Int -> SP Builder
        goStu i a =
          let (_, len, s) = groupInfos!(groupOrder!i)
              avg' = traceShowId $ (s - a) % (len - 1)
              findPos l r
                | l == r  = l
                | avg' <= avg = findPos (m + 1) r
                | otherwise = findPos l m
                where
                  m = (l + r) `div` 2
                  (avg, _, _) = traceShowId $ groupInfos!(groupOrder!m)
              i' = findPos 1 (m + 1)
          in if avg' <= (teacherAges!i)%1 && ok i i' then pure $ char7 '1'
             else pure $ char7 '0'
        checkPos p l r = S.member p $ unPS $ queryITree l r posTree
        ok i i' = traceShow ("See ", s, t) $ (s <= 1 || checkPos O 1 (s - 1))
            && okMid d s t
            && (t > m || checkPos O t m)
          where
            s = min i i'
            t = max i i'
            d
              | i' == i + 1 || i' == i = O
              | i' > i = R
              | otherwise = L
        okMid O _ _ = True
        okMid L l r = checkPos R l (r - 1)
        okMid R l r = checkPos L (l + 1) (r - 1)
    (<>char7 '\n')<$>mconcat<$> mapM goGrp [1..m]
  where
    groupInfo l s = (s % l, l, s)

type SP = State [P.ByteString]

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

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

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

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

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

{-# LANGUAGE DeriveFunctor #-}

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.Ratio
import qualified Data.Set as S

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

data BinTree a = BinLeaf a | BinNode a (BinTree a) (BinTree a)
  deriving (Show, Eq, Functor)
data IntervalTree a = IT (Int,  Int) (BinTree a)

binAnn (BinLeaf v) = v
binAnn (BinNode v _ _) = v

buildITree :: (Monoid e, IArray a e) => a Int e -> IntervalTree e
buildITree a = let (l, r) = bounds a in IT (l, r) $ go l r
  where
    go l r =
      if l == r then BinLeaf (a!l)
      else
        let mid = (l + r) `div` 2
            lt = go l mid
            rt = go (mid + 1) r
        in BinNode (binAnn lt <> binAnn rt) lt rt

queryITree :: Monoid e => Int -> Int -> IntervalTree e -> e
queryITree ql qr (IT (l, r) bt) = go l r bt
  where
    go _ _ (BinLeaf v) = v
    go l' r' (BinNode a lt rt)
      | ql > r' || qr < l' = mempty
      | ql <= l' && qr >= r' = a
      | qr <= m = la
      | ql > m = ra
      | otherwise = la <> ra
      where
        m = (l' + r') `div` 2
        la = go l m lt
        ra = go (m + 1) r rt

data Pos = L | R | O deriving (Show, Eq, Ord)
newtype PosSet = PS {unPS :: S.Set Pos} deriving (Show, Eq)

instance Semigroup PosSet where
  (PS a) <> (PS b) = PS $ S.intersection a b

instance Monoid PosSet where
  mempty = PS $ S.fromList [L, R, O]

type ITPos = IntervalTree PosSet

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n, m] <- getInts 2
    ta <- getInts n
    sg <- replicateM m $ (head <$>getInts 1) >>= getInts
    let ta' = take m $ sortOn negate ta
        teacherAges :: UArray Int Int
        teacherAges = listArray (1, m) ta'
        studentGroups :: Array Int [Int]
        studentGroups = listArray (1, m) sg
        groupInfos = amap (groupInfo<$>length<*>sum) studentGroups
        groupOrder :: UArray Int Int
        groupOrder = listArray (1, m) $ sortOn
          (\i -> let (x, _, _) = groupInfos!i in negate x) [1..m]
        revOrder :: UArray Int Int
        revOrder = array (1, m) $ (\(x, y) -> (y, x)) <$> assocs groupOrder
        add pos f = if f then S.singleton pos else S.empty
        getPosSet i = PS $ (add L $ i > 1 && teacherAges!(i - 1) % 1 > avg)
          <> (add O $ teacherAges!i % 1 > avg)
          <> (add R $ i < m && teacherAges!(i + 1) % 1 > avg)
          where (avg, _, _) = groupInfos!(groupOrder!i)
        posSets :: Array Int PosSet
        posSets = listArray (1, m) [getPosSet i | i <- [1..m]]
        posTree = buildITree posSets
        goGrp :: Int -> SP Builder
        goGrp ri = let i = revOrder!ri in mconcat<$>(sequence $ goStu i<$>studentGroups!(groupOrder!i))
        goStu :: Int -> Int -> SP Builder
        goStu i a =
          let (_, len, s) = groupInfos!(groupOrder!i)
              avg' = (s - a) % (len - 1)
              findPos l r
                | l == r  = l
                | avg' <= avg = findPos (m + 1) r
                | otherwise = findPos l m
                where
                  m = (l + r) `div` 2
                  (avg, _, _) = groupInfos!(groupOrder!m)
              i' = findPos 1 (m + 1)
          in if avg' <= (teacherAges!i)%1 && ok i i' then pure $ char7 '1'
             else pure $ char7 '0'
        checkPos p l r = S.member p $ unPS $ queryITree l r posTree
        ok i i' = (s <= 1 || checkPos O 1 (s - 1))
            && okMid d s t
            && (t > m || checkPos O t m)
          where
            s = min i i'
            t = max i i'
            d
              | i' == i + 1 || i' == i = O
              | i' > i = R
              | otherwise = L
        okMid O _ _ = True
        okMid L l r = checkPos R l (r - 1)
        okMid R l r = checkPos L (l + 1) (r - 1)
    (<>char7 '\n')<$>mconcat<$> mapM goGrp [1..m]
  where
    groupInfo l s = (s % l, l, s)

type SP = State [P.ByteString]

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

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

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

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

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


Alice has an empty grid with $$$n$$$ rows and $$$m$$$ columns. Some of the cells are marked, and no marked cells are adjacent to the edge of the grid. (Two squares are adjacent if they share a side.) Alice wants to fill each cell with a number such that the following statements are true:   every unmarked cell contains either the number $$$1$$$ or $$$4$$$;  every marked cell contains the sum of the numbers in all unmarked cells adjacent to it (if a marked cell is not adjacent to any unmarked cell, this sum is $$$0$$$);  every marked cell contains a multiple of $$$5$$$.  Alice couldn't figure it out, so she asks Bob to help her. Help Bob find any such grid, or state that no such grid exists.

The first line of input contains two integers $$$n$$$ and $$$m$$$ ($$$1 \leq n, m \leq 500$$$) — the number of rows and the number of columns in the grid, respectively. Then $$$n$$$ lines follow, each containing $$$m$$$ characters. Each of these characters is either '.' or 'X' — an unmarked and a marked cell, respectively. No marked cells are adjacent to the edge of the grid.

Output "'NO" if no suitable grid exists. Otherwise, output "'YES"'. Then output $$$n$$$ lines of $$$m$$$ space-separated integers — the integers in the grid.

NoteIt can be shown that no such grid exists for the second test.

-- This is a kind-of stupid way to implement the solution

{-# LANGUAGE FlexibleContexts #-}
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.Semigroup
--import Data.ByteString.Builder.Extra (flush) -- for interactive problems
import Control.Monad
import Data.List
import Data.Array.Unboxed
import Data.Array.ST.Safe

import Debug.Trace

solve :: UArray (Int, Int) Bool -> Maybe (UArray (Int, Int) Int)
solve marks = let
  ((1, 1), (n, m)) = bounds marks
  neighbors (i, j)
    =  [(i - 1, j) | i > 1]
    ++ [(i, j - 1) | j > 1]
    ++ [(i + 1, j) | i < n]
    ++ [(i, j + 1) | j < m]
  isPossible = and $ do
    (x, True) <- assocs marks
    pure $ even $ length [() | y <- neighbors x, marks ! y]
  in  if  not isPossible
  then  Nothing
  else  Just $ runSTUArray $ do
  ans <- newArray ((1, 1), (n, m)) 0
  let
    prop pos = if  not (marks ! pos)
      then  pure ()
      else  do
      val <- readArray ans pos
      when (val == 0) $ let -- loop detection
        unmarkedNs = filter (not . (!) marks) $ neighbors pos
        toProcess = do
          _iters <- [(), ()]
          zip unmarkedNs $ tail $ cycle unmarkedNs
        in  do
        forM_ toProcess $ \(x, y) -> do
          vx <- readArray ans x
          when (vx /= 0) $ writeArray ans y (5 - vx)
        writeArray ans pos $ 5 * length unmarkedNs `div` 2
        forM_ unmarkedNs $ (`forM_` prop) . neighbors

  forM_ (indices marks) $ \pos -> do
    val <- readArray ans pos
    when (marks ! pos && val == 0) $ do
      let  unmarkedNs = filter (not . (!) marks) $ neighbors pos
      case  unmarkedNs  of
        [] -> pure ()
        x : _ -> writeArray ans x 1 >> prop pos

  forM_ (indices marks) $ \pos -> do
    val <- readArray ans pos
    when (not (marks ! pos) && val == 0) $ writeArray ans pos 1
  pure ans

chunksOf :: Int -> [t] -> [[t]]
chunksOf k = unfoldr $ \li -> do
  guard $ not $ null li
  pure $ splitAt k li

mainFun :: SO
mainFun = do
  ~[n, m] <- getInts 2
  a <- getNext n
  let
    marks = listArray ((1, 1), (n, m))
      $ [aij == 'X' | aij <- concatMap P.unpack a]
    neighbors (i, j)
      =  [(i - 1, j) | i > 1]
      ++ [(i, j - 1) | j > 1]
      ++ [(i + 1, j) | i < n]
      ++ [(i, j + 1) | j < m]
    isSane ans = and $ do
      (pos, v) <- assocs marks
      pure $ traceShow ("isSane", pos, v) $ if  not v
        then  elem (ans ! pos) [1, 4]
        else  let
        w1 = ans ! pos
        w2 = sum [ans ! npos | npos <- neighbors pos, not (marks ! npos)]
        in  w1 == w2 && w1 `mod` 5 == 0
  pure $ case  solve marks  of
    Nothing -> string7 "NO\n"
    {-
    Just ans | isSane ans -> string7 "YES\n"
      <> mconcat [putInts li | li <- chunksOf m $ elems ans]
    -}
    Just ans -> string7 "YES\n" -- "YIKES\n"
      <> mconcat [putInts li | li <- chunksOf m $ elems ans]

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


You have an array a consisting of n integers. Each integer from 1 to n appears exactly once in this array.For some indices i (1 ≤ i ≤ n - 1) it is possible to swap i-th element with (i + 1)-th, for other indices it is not possible. You may perform any number of swapping operations any order. There is no limit on the number of times you swap i-th element with (i + 1)-th (if the position is not forbidden).Can you make this array sorted in ascending order performing some sequence of swapping operations?

The first line contains one integer n (2 ≤ n ≤ 200000) — the number of elements in the array. The second line contains n integers a1, a2, ..., an (1 ≤ ai ≤ 200000) — the elements of the array. Each integer from 1 to n appears exactly once. The third line contains a string of n - 1 characters, each character is either 0 or 1. If i-th character is 1, then you can swap i-th element with (i + 1)-th any number of times, otherwise it is forbidden to swap i-th element with (i + 1)-th.

If it is possible to sort the array in ascending order using any sequence of swaps you are allowed to make, print YES. Otherwise, print NO.

NoteIn the first example you may swap a3 and a4, and then swap a4 and a5.

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -funfolding-use-threshold=16 -fexcess-precision -funbox-strict-fields #-}
{-# LANGUAGE ViewPatterns #-}
module Main where
import qualified Data.ByteString.Char8 as B
import Control.Monad
import Control.Monad.Trans.State.Strict
import Data.Char
import Data.Array.Unboxed
import Data.Bool

main = B.interact exec
exec = B.pack . evalState app . B.words
app = do
  n <- poi
  xs <- replicateM n poi
  ys <- pop
  return $ bool "NO" "YES" $ solve n xs $ map digitToInt $ B.unpack ys
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve n xs (listArray (1, n) . scanl (+) 0 -> ys) = and $ zipWith ok xs [1..]
  where
  _ = ys :: UArray Int Int
  ok l r
    | l > r = ok r l
    | otherwise = ys!r - ys!l == r - l

import Data.List

main = getLine >> fmap (map read.words) getLine >>= \l -> getLine >>= putStrLn . (solve l)

solve :: [Int] -> String -> String
solve a b
    | ascending $ concat $ map reduce $ groupList a b = "YES"
    | otherwise = "NO"

groupList [a] [] = [[a]]
groupList (x:xs) (y:ys)
    | y == '1' = (\x (y:ys) -> (x:y):ys) x $ groupList xs ys
    | otherwise = [x] : (groupList xs ys)

ascending [_] = True
ascending (x:y:xs)
    | x <= y = ascending (y:xs)
    | otherwise = False

reduce [x] = [x]
reduce xs = [minimum xs, maximum xs]

import Data.List

main = getLine >> fmap words getLine >>= \l -> getLine >>= putStrLn . (solve l)

solve a b
    | sort a == (concat $ map sort $ groupList a b) = "YES"
    | otherwise = "NO"

groupList [a] [] = [[a]]
groupList (x:xs) (y:ys)
    | y == '1' = (\x (y:ys) -> (x:y):ys) x (groupList xs ys)
    | otherwise = [x] : (groupList xs ys)


You are given an undirected graph with weighted edges. The length of some path between two vertices is the bitwise xor of weights of all edges belonging to this path (if some edge is traversed more than once, then it is included in bitwise xor the same number of times). You have to find the minimum length of path between vertex 1 and vertex n.Note that graph can contain multiple edges and loops. It is guaranteed that the graph is connected.

The first line contains two numbers n and m (1 ≤ n ≤ 100000, n - 1 ≤ m ≤ 100000) — the number of vertices and the number of edges, respectively. Then m lines follow, each line containing three integer numbers x, y and w (1 ≤ x, y ≤ n, 0 ≤ w ≤ 108). These numbers denote an edge that connects vertices x and y and has weight w.

Print one number — the minimum length of path between vertices 1 and n.

-- 845F

--{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)
import Data.List (foldl', sort, delete)
import Data.Bits
import Data.Array
import Data.Array.ST.Safe
import Control.Monad (foldM)
import Control.Monad.ST.Safe

type Graph s = STArray s Int [(Int, Int)]
type IGraph = Array Int [(Int, Int)]

updateArray a i f = readArray a i >>= (\v -> writeArray a i $ f v)
toInt = fst . fromJust . B.readInt
readIntLine = map toInt . B.words
xorMin n i = min (i `xor` n) i

main = do
  (n:m:_) <- fmap (map read . words) getLine
  B.interact $ output . program (n, m) . map readIntLine . B.lines
      where output = B.pack . show

program :: (Int, Int) -> [[Int]] -> Int
program (n, m) xs =
  let graph = runSTArray $ do
        empty <- newArray (1, n) []
        foldM makeEdge empty xs
      (set, target) = getNSet graph n
  in foldl' (flip xorMin) target . rref $ set

makeEdge :: Graph s -> [Int] -> ST s (Graph s)
makeEdge g [x, y, w] = do
  let weight = fromIntegral w
  updateArray g x ((:) (y, weight))
  if x /= y
    then updateArray g y ((:) (x, weight))
    else return ()
  return g

getNSet :: IGraph -> Int -> (Set.Set Int, Int)
getNSet g n = fst $ dfs Map.empty 1 0 Set.empty 0
  where dfs :: Map.Map Int Int -> Int -> Int -> Set.Set Int -> Int -> ((Set.Set Int, Int), Map.Map Int Int)
        dfs vis from xorsum xorsums target
          | from `Map.member` vis =
              let prevSum = (Map.!) vis from
                  xorsums' = Set.insert (xorsum `xor` prevSum) xorsums
              in ((xorsums', target), vis)
          | otherwise =
              let addNeighbor ((xorsums, target), vis) (to, weight) =
                    let xorsum' = weight `xor` xorsum
                        target' = if to == n then xorsum' else target
                    in dfs vis to xorsum' xorsums target'
              in foldl' addNeighbor ((xorsums, target), Map.insert from xorsum vis) (g ! from)

rref :: Set.Set Int -> [Int]
rref set
  | Set.null set = []
  | otherwise = x:(rref set')
  where x = Set.findMax set
        set' = Set.map (xorMin x) $ Set.deleteMax set

-- 845F

--{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)
import Data.List (foldl')
import Data.Bits
import Data.Array
import Data.Array.ST.Safe
import Control.Monad (foldM)
import Control.Monad.ST.Safe

type Graph s = STArray s Int [(Int, Int)]
type IGraph = Array Int [(Int, Int)]

updateArray a i f = readArray a i >>= (\v -> writeArray a i $ f v)
toInt = fst . fromJust . B.readInt
readIntLine = map toInt . B.words
log2 n = length (takeWhile (<=n) (iterate (*2) 2))
xorIfSet i n = if i `testBit` (log2 n) then i `xor` n else i

main = do
  (n:m:_) <- fmap (map read . words) getLine
  B.interact $ output . program (n, m) . map readIntLine . B.lines
      where output = B.pack . show

program :: (Int, Int) -> [[Int]] -> Int
program (n, m) xs =
  let graph = runSTArray $ do
        empty <- newArray (1, n) []
        foldM makeEdge empty xs
      (set, target) = getNSet graph n
  in foldl' xorIfSet target . rref . Set.toDescList $ set

makeEdge :: Graph s -> [Int] -> ST s (Graph s)
makeEdge g [x, y, w] = do
  let weight = fromIntegral w
  updateArray g x ((:) (y, weight))
  if x /= y
    then updateArray g y ((:) (x, weight))
    else return ()
  return g

getNSet :: IGraph -> Int -> (Set.Set Int, Int)
getNSet g n = fst $ dfs Map.empty 1 0 Set.empty 0
  where dfs :: Map.Map Int Int -> Int -> Int -> Set.Set Int -> Int -> ((Set.Set Int, Int), Map.Map Int Int)
        dfs vis from xorsum xorsums target
          | from `Map.member` vis =
              let prevSum = (Map.!) vis from
                  xorsums' = Set.insert (xorsum `xor` prevSum) xorsums
              in ((xorsums', target), vis)
          | otherwise =
              let addNeighbor ((xorsums, target), vis) (to, weight) =
                    let xorsum' = weight `xor` xorsum
                        target' = if to == n then xorsum' else target
                    in dfs vis to xorsum' xorsums target'
              in foldl' addNeighbor ((xorsums, target), Map.insert from xorsum vis) (g ! from)

rref :: [Int] -> [Int]
rref xs = solveNthBit (log2 $ head xs) xs
solveNthBit (-1) xs     = xs
solveNthBit _    []     = []
solveNthBit n    (x:xs) = x:(solveNthBit (n - 1) xs')
  where xs' = insSort . map (xorIfSet (bit n)) $ xs
insert x []     = [x]
insert x (y:ys) = if x > y then x:y:ys else y:insert x ys
insSort []     = []
insSort (x:xs) = insert x $ insSort xs


You are given a grid with $$$n$$$ rows and $$$m$$$ columns. Rows and columns are numbered from $$$1$$$ to $$$n$$$, and from $$$1$$$ to $$$m$$$. The intersection of the $$$a$$$-th row and $$$b$$$-th column is denoted by $$$(a, b)$$$. Initially, you are standing in the top left corner $$$(1, 1)$$$. Your goal is to reach the bottom right corner $$$(n, m)$$$.You can move in four directions from $$$(a, b)$$$: up to $$$(a-1, b)$$$, down to $$$(a+1, b)$$$, left to $$$(a, b-1)$$$ or right to $$$(a, b+1)$$$.You cannot move in the same direction in two consecutive moves, and you cannot leave the grid. What is the minimum number of moves to reach $$$(n, m)$$$?

The input consists of multiple test cases. The first line contains a single integer $$$t$$$ ($$$1 \le t \le 10^3$$$) — the number of the test cases. The description of the test cases follows. The first line of each test case contains two integers $$$n$$$ and $$$m$$$ ($$$1 \le n, m \le 10^9$$$) — the size of the grid.

For each test case, print a single integer: $$$-1$$$ if it is impossible to reach $$$(n, m)$$$ under the given conditions, otherwise the minimum number of moves.

NoteTest case $$$1$$$: $$$n=1$$$, $$$m=1$$$, and initially you are standing in $$$(1, 1)$$$ so $$$0$$$ move is required to reach $$$(n, m) = (1, 1)$$$.Test case $$$2$$$: you should go down to reach $$$(2, 1)$$$.Test case $$$3$$$: it is impossible to reach $$$(1, 3)$$$ without moving right two consecutive times, or without leaving the grid.Test case $$$4$$$: an optimal moving sequence could be: $$$(1, 1) \to (1, 2) \to (2, 2) \to (2, 1) \to (3, 1) \to (3, 2) \to (4, 2)$$$. It can be proved that this is the optimal solution. So the answer is $$$6$$$.

--
--    author:  bernborgess
--    problem: 1668a - forImperativeProgrammers
--    created: 19.April.2022 22:33:25
--

import Control.Monad

solve :: [Int] -> Int
solve [] = 0
solve (n : m : []) =
  if n < m then solve [m, n]
  else if n > 2 && m == 1 then -1
  else 2 * (m - 1) + 4 * ((n - m) `div` 2) + (n - m) `mod` 2

main :: IO ()
main = do ids >>= mapM_ (fn >=> print)
  where
    ids = enumFromTo 1 . read <$> getLine
    fn tc = solve . map read . words <$> getLine


Ivan has n different boxes. The first of them contains some balls of n different colors.Ivan wants to play a strange game. He wants to distribute the balls into boxes in such a way that for every i (1 ≤ i ≤ n) i-th box will contain all balls with color i.In order to do this, Ivan will make some turns. Each turn he does the following:  Ivan chooses any non-empty box and takes all balls from this box;  Then Ivan chooses any k empty boxes (the box from the first step becomes empty, and Ivan is allowed to choose it), separates the balls he took on the previous step into k non-empty groups and puts each group into one of the boxes. He should put each group into a separate box. He can choose either k = 2 or k = 3. The penalty of the turn is the number of balls Ivan takes from the box during the first step of the turn. And penalty of the game is the total penalty of turns made by Ivan until he distributes all balls to corresponding boxes.Help Ivan to determine the minimum possible penalty of the game!

The first line contains one integer number n (1 ≤ n ≤ 200000) — the number of boxes and colors. The second line contains n integer numbers a1, a2, ..., an (1 ≤ ai ≤ 109), where ai is the number of balls with color i.

Print one number — the minimum possible penalty of the game.

NoteIn the first example you take all the balls from the first box, choose k = 3 and sort all colors to corresponding boxes. Penalty is 6.In the second example you make two turns:   Take all the balls from the first box, choose k = 3, put balls of color 3 to the third box, of color 4 — to the fourth box and the rest put back into the first box. Penalty is 14;  Take all the balls from the first box, choose k = 2, put balls of color 1 to the first box, of color 2 — to the second box. Penalty is 5. Total penalty is 19.

import Control.Applicative ((<$>))
import Control.Monad.State
import Data.Int
import Data.List (sort, unfoldr)
import qualified Data.ByteString.Lazy.Char8 as L

class Heap h where
    empty :: h a
    singleton :: (Ord a) => a -> h a

    isSingleton :: (Ord a) => h a -> Bool

    merge :: (Ord a) => h a -> h a -> h a
    push :: (Ord a) => a -> h a -> h a
    pop :: (Ord a) => h a -> (a, h a)
    fromList :: (Ord a) => [a] -> h a

data LeftistHeap a = Empty
                   | Node a Int (LeftistHeap a) (LeftistHeap a)
                     deriving (Show, Eq)

size :: LeftistHeap a -> Int
size Empty = 0
size (Node _ s _ _) = s

makeHeap :: (Ord a) => a -> LeftistHeap a -> LeftistHeap a -> LeftistHeap a
makeHeap x yh zh | ys > zs = Node x (ys + 1) yh zh
                 | otherwise = Node x (zs + 1) zh yh
    where ys = size yh
          zs = size zh

instance Heap LeftistHeap where
    empty = Empty
    singleton a = Node a 1 Empty Empty

    isSingleton (Node _ _ Empty Empty)  = True
    isSingleton _ = False

    merge Empty h2 = h2
    merge h1 Empty = h1
    merge h1@(Node x s1 l1 r1) h2@(Node y s2 l2 r2) | x < y = makeHeap x l1 (merge r1 h2)
                                                    | otherwise = makeHeap y l2 (merge h1 r2)

    push a h = merge h (singleton a)

    pop Empty = error $ "Can't pop from empty heap"
    pop (Node x _ h1 h2) = (x, merge h1 h2)

    fromList [] = empty
    fromList xs = head . head . dropWhile (not . converged) $ iterate (unfoldr join) hs
        where hs = map singleton xs
              join [] = Nothing
              join [x] = Just (x, [])
              join (x:y:zs) = Just (merge x y, zs)

              converged [x] = True
              converged _ = False

type Context = State (Int64, LeftistHeap Int64)

solve :: [Int64] -> Int64
solve [] = 0
solve [_] = 0
solve xs = evalState go (0, fromList xs')
    where xs' | even (length xs) = 0:xs
              | otherwise = xs

          popQ :: Context Int64
          popQ = state $ \(n, h) -> let (x, h') = pop h in (x, (n, h'))

          go :: Context Int64
          go = do
            (n, h) <- get
            if isSingleton h
            then return n
            else do a <- popQ
                    b <- popQ
                    c <- popQ
                    let m = a + b + c
                    modify (\(n, h) -> (n + m, push m h))
                    go

test0 = [1, 2, 3] :: [Int64]
test1 = [2, 3, 4, 5] :: [Int64]

type Tokenizer = State [L.ByteString]

nextInt :: Tokenizer Int
nextInt = state $ \(s:ss) -> case L.readInt s of
                               Just (x, _) -> (x, ss)
                               Nothing -> error "Can't parse Int"

go :: Tokenizer Int64
go = do
  n  <- nextInt
  as <- map fromIntegral <$> replicateM n nextInt
  return $ solve as

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

import Control.Applicative ((<$>))
import Control.Monad.State
import Data.Int
import Data.List (sort)
import qualified Data.ByteString.Lazy.Char8 as L

class Heap h where
    empty :: h a
    singleton :: (Ord a) => a -> h a

    isSingleton :: (Ord a) => h a -> Bool

    merge :: (Ord a) => h a -> h a -> h a
    push :: (Ord a) => a -> h a -> h a
    pop :: (Ord a) => h a -> (a, h a)
    fromList :: (Ord a) => [a] -> h a

data LeftistHeap a = Empty
                   | Node a Int (LeftistHeap a) (LeftistHeap a)
                     deriving (Show, Eq)

size :: LeftistHeap a -> Int
size Empty = 0
size (Node _ s _ _) = s

makeHeap :: (Ord a) => a -> LeftistHeap a -> LeftistHeap a -> LeftistHeap a
makeHeap x yh zh | ys > zs = Node x (ys + 1) yh zh
                 | otherwise = Node x (zs + 1) zh yh
    where ys = size yh
          zs = size zh

instance Heap LeftistHeap where
    empty = Empty
    singleton a = Node a 1 Empty Empty

    isSingleton (Node _ _ Empty Empty)  = True
    isSingleton _ = False

    merge Empty h2 = h2
    merge h1 Empty = h1
    merge h1@(Node x s1 l1 r1) h2@(Node y s2 l2 r2) | x < y = makeHeap x l1 (merge r1 h2)
                                                    | otherwise = makeHeap y l2 (merge h1 r2)

    push a h = merge h (singleton a)

    pop Empty = error $ "Can't pop from empty heap"
    pop (Node x _ h1 h2) = (x, merge h1 h2)

    fromList [] = empty
    fromList xs = go $ map singleton xs
        where go [] = empty
              go [h] = h
              go hs = go $ joinPairs hs

              joinPairs [] = []
              joinPairs [x] = [x]
              joinPairs (x:y:zs) = (merge x y):joinPairs zs

type Context = State (Int64, LeftistHeap Int64)

solve :: [Int64] -> Int64
solve [] = 0
solve [_] = 0
solve xs = evalState go (0, fromList xs')
    where xs' | even (length xs) = 0:xs
              | otherwise = xs

          popQ :: Context Int64
          popQ = state $ \(n, h) -> let (x, h') = pop h in (x, (n, h'))

          go :: Context Int64
          go = do
            (n, h) <- get
            if isSingleton h
            then return n
            else do a <- popQ
                    b <- popQ
                    c <- popQ
                    let m = a + b + c
                    modify (\(n, h) -> (n + m, push m h))
                    go

test0 = [1, 2, 3] :: [Int64]
test1 = [2, 3, 4, 5] :: [Int64]

type Tokenizer = State [L.ByteString]

nextInt :: Tokenizer Int
nextInt = state $ \(s:ss) -> case L.readInt s of
                               Just (x, _) -> (x, ss)
                               Nothing -> error "Can't parse Int"

go :: Tokenizer Int64
go = do
  n  <- nextInt
  as <- map fromIntegral <$> replicateM n nextInt
  return $ solve as

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

import Control.Applicative ((<$>))
import Control.Monad.State
import Data.Int
import Data.List (sort, unfoldr)
import qualified Data.ByteString.Lazy.Char8 as L

class Heap h where
    empty :: h a
    singleton :: (Ord a) => a -> h a

    isSingleton :: (Ord a) => h a -> Bool

    merge :: (Ord a) => h a -> h a -> h a
    push :: (Ord a) => a -> h a -> h a
    pop :: (Ord a) => h a -> (a, h a)
    fromList :: (Ord a) => [a] -> h a

data LeftistHeap a = Empty
                   | Node a Int (LeftistHeap a) (LeftistHeap a)
                     deriving (Show, Eq)

size :: LeftistHeap a -> Int
size Empty = 0
size (Node _ s _ _) = s

makeHeap :: (Ord a) => a -> LeftistHeap a -> LeftistHeap a -> LeftistHeap a
makeHeap x yh zh | ys > zs = Node x (ys + 1) yh zh
                 | otherwise = Node x (zs + 1) zh yh
    where ys = size yh
          zs = size zh

instance Heap LeftistHeap where
    empty = Empty
    singleton a = Node a 1 Empty Empty

    isSingleton (Node _ _ Empty Empty)  = True
    isSingleton _ = False

    merge Empty h2 = h2
    merge h1 Empty = h1
    merge h1@(Node x s1 l1 r1) h2@(Node y s2 l2 r2) | x < y = makeHeap x l1 (merge r1 h2)
                                                    | otherwise = makeHeap y l2 (merge h1 r2)

    push a h = merge h (singleton a)

    pop Empty = error $ "Can't pop from empty heap"
    pop (Node x _ h1 h2) = (x, merge h1 h2)

    fromList [] = empty
    fromList xs = head . head . dropWhile (not.converged) $ iterate (unfoldr join) hs
        where hs = map singleton xs
              join [] = Nothing
              join [x] = Just (x, [])
              join (x:y:zs) = Just (merge x y, zs)

              converged [x] = True
              converged _ = False

type Context = State (Int64, LeftistHeap Int64)

solve :: [Int64] -> Int64
solve [] = 0
solve [_] = 0
solve xs = evalState go (0, fromList xs')
    where xs' | even (length xs) = 0:xs
              | otherwise = xs

          popQ :: Context Int64
          popQ = state $ \(n, h) -> let (x, h') = pop h in (x, (n, h'))

          go :: Context Int64
          go = do
            (n, h) <- get
            if isSingleton h
            then return n
            else do a <- popQ
                    b <- popQ
                    c <- popQ
                    let m = a + b + c
                    modify (\(n, h) -> (n + m, push m h))
                    go

test0 = [1, 2, 3] :: [Int64]
test1 = [2, 3, 4, 5] :: [Int64]

type Tokenizer = State [L.ByteString]

nextInt :: Tokenizer Int
nextInt = state $ \(s:ss) -> case L.readInt s of
                               Just (x, _) -> (x, ss)
                               Nothing -> error "Can't parse Int"

go :: Tokenizer Int64
go = do
  n  <- nextInt
  as <- map fromIntegral <$> replicateM n nextInt
  return $ solve as

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


Phoenix loves beautiful arrays. An array is beautiful if all its subarrays of length $$$k$$$ have the same sum. A subarray of an array is any sequence of consecutive elements.Phoenix currently has an array $$$a$$$ of length $$$n$$$. He wants to insert some number of integers, possibly zero, into his array such that it becomes beautiful. The inserted integers must be between $$$1$$$ and $$$n$$$ inclusive. Integers may be inserted anywhere (even before the first or after the last element), and he is not trying to minimize the number of inserted integers.

The input consists of multiple test cases. The first line contains an integer $$$t$$$ ($$$1 \le t \le 50$$$) — the number of test cases. The first line of each test case contains two integers $$$n$$$ and $$$k$$$ ($$$1 \le k \le n \le 100$$$). The second line of each test case contains $$$n$$$ space-separated integers ($$$1 \le a_i \le n$$$) — the array that Phoenix currently has. This array may or may not be already beautiful.

For each test case, if it is impossible to create a beautiful array, print -1. Otherwise, print two lines. The first line should contain the length of the beautiful array $$$m$$$ ($$$n \le m \le 10^4$$$). You don't need to minimize $$$m$$$. The second line should contain $$$m$$$ space-separated integers ($$$1 \le b_i \le n$$$) — a beautiful array that Phoenix can obtain after inserting some, possibly zero, integers into his array $$$a$$$. You may print integers that weren't originally in array $$$a$$$. If there are multiple solutions, print any. It's guaranteed that if we can make array $$$a$$$ beautiful, we can always make it with resulting length no more than $$$10^4$$$.

NoteIn the first test case, we can make array $$$a$$$ beautiful by inserting the integer $$$1$$$ at index $$$3$$$ (in between the two existing $$$2$$$s). Now, all subarrays of length $$$k=2$$$ have the same sum $$$3$$$. There exists many other possible solutions, for example:   $$$2, 1, 2, 1, 2, 1$$$  $$$1, 2, 1, 2, 1, 2$$$ In the second test case, the array is already beautiful: all subarrays of length $$$k=3$$$ have the same sum $$$5$$$.In the third test case, it can be shown that we cannot insert numbers to make array $$$a$$$ beautiful.In the fourth test case, the array $$$b$$$ shown is beautiful and all subarrays of length $$$k=4$$$ have the same sum $$$10$$$. There exist other solutions also.

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

main = getLine >>= flip replicateM_ test . read

test = do
    (n:k:_) <- map read . words <$> getLine
    as <- map read . words <$> getLine :: IO [Integer]
    let ms = nub as
    if length ms > k
        then print (-1)
        else do
            print $ n * k
            putStrLn $ unwords . map show $ take (n * k) $ cycle $ take k $ ms ++ repeat 1

import Control.Monad
import qualified Data.Set as S

readIs :: IO [Int]
readIs = fmap read . words <$> getLine

main :: IO ()
main = do
  t <- head <$> readIs
  replicateM_ t $ do
    [n,k] <- readIs
    s <- S.fromList <$> readIs
    case solve n k s of
      Nothing -> putStrLn "-1"
      Just xs -> print (n*k) >> putStrLn (unwords (show <$> xs))

solve :: Int -> Int -> S.Set Int -> Maybe [Int]
solve n k s | S.size s > k = Nothing
solve n k s = Just $ take (n*k) $ cycle $ S.toList $ grow s n
  where
    size = S.size s
    grow s 0 = s
    grow s _ | S.size s == k = s
    grow s n = grow (S.insert n s) (n-1)

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

readInts :: IO [Int]
readInts = do
    input <- getLine
    return $ map read . words $ input

printAnswer :: [Int] -> IO ()
printAnswer [] = putStrLn "-1"
printAnswer ans = do
    print $ length ans
    putStrLn $ unwords $ map show ans

solve :: [Int] -> Int -> Int -> [Int]
solve unique n k
    | len > k = []
    | otherwise = take (n * k) $ L.cycle unique'
    where
        len = length unique
        unique' = L.replicate (k - len) 1 ++ unique

handle_test :: Int -> IO()
handle_test 0 = do return ()
handle_test t =  do
    [n, k] <- readInts
    a <- readInts
    let unique = S.toList (S.fromList a) in
        printAnswer $ solve unique n k
    handle_test $ t - 1

main = do
    t <- getLine
    handle_test $ read t

import qualified Data.List as L

solve :: Int -> Int -> [Int] -> [Int]
solve n k as
    | uniqueSize > k     = []
    | otherwise = take (n*k) $ L.cycle block
    where
        unique = map head $ L.group $ L.sort as
        uniqueSize = length unique
        block = L.replicate (k-uniqueSize) 1 ++ unique

testCases :: Int -> IO ()
testCases 0 = return ()
testCases t = do
    (n:k:_) <- readInts
    as <- readInts
    printSolution $ solve n k as
    testCases (t-1)

printSolution :: [Int] -> IO ()
printSolution [] = putStrLn "-1"
printSolution bs = do
    print $ length bs
    putStrLn $ unwords $ map show bs

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

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

import Control.Monad
import qualified Data.Set as S

readIs :: IO [Int]
readIs = fmap read . words <$> getLine

main :: IO ()
main = do
  t <- head <$> readIs
  replicateM_ t $ do
    [n,k] <- readIs
    s <- S.fromList <$> readIs
    case solve n k s of
      Nothing -> putStrLn "-1"
      Just xs -> print (n*k) >> putStrLn (unwords (show <$> xs))

solve :: Int -> Int -> S.Set Int -> Maybe [Int]
solve n k s | S.size s > k = Nothing
solve n k s = Just $ take (n*k) $ cycle (S.toList s)

import Control.Monad
import qualified Data.Set as S

readIs :: IO [Int]
readIs = fmap read . words <$> getLine

main :: IO ()
main = do
  t <- head <$> readIs
  replicateM_ t $ do
    [n,k] <- readIs
    s <- S.fromList <$> readIs
    case solve n k s of
      Nothing -> putStrLn "-1"
      Just xs -> print (n*k) >> putStrLn (unwords (show <$> xs))

solve :: Int -> Int -> S.Set Int -> Maybe [Int]
solve n k s | S.size s > k = Nothing
solve n k s = Just $ take (n*k) $ cycle (S.toList s1)
  where
    size = S.size s
    s1 = S.union
          s
          (S.fromList $ take (k-size) (enumFrom $ succ $ S.findMax s))

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

printList :: [Int] -> Int -> IO()
printList _ 0  = do putStr "\n"
printList list n = do
    putStr $ ( ++ " ") . unwords $  map show list
    printList list  $ n - 1

solve :: [Int] -> Int -> Int -> IO ()
solve unique n k =
    printList unique' n
    where
        high = last unique
        len = length unique
        unique' = unique ++  [x * high | x <- [1 .. len - k]]

readInts :: IO [Int]
readInts = do
    input <- getLine
    return $ map read . words $ input

handle_test :: Int -> IO()
handle_test 0 = do return ()
handle_test t =  do
    [n, k] <- readInts
    a <- readInts
    let unique = S.toList (S.fromList a)
    if length unique <= k then
        solve unique n k
    else
        print $ -1
    handle_test $ t - 1

main = do
    t <- getLine
    handle_test $ read t

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

printList :: [Int] -> Int -> IO()
printList _ 0  = do putStr "\n"
printList list n = do
    putStr $ ( ++ " ") . unwords $  map show list
    printList list  $ n - 1

solve :: [Int] -> Int -> Int -> IO ()
solve unique n k =
    printList unique' n
    where
        high = last unique
        len = length unique
        unique' = unique ++  [x * high | x <- [1 .. len - k]]

readInts :: IO [Int]
readInts = do
    input <- getLine
    return $ map read . words $ input

handle_test :: Int -> IO()
handle_test 0 = do return ()
handle_test t =  do
    [n, k] <- readInts
    a <- readInts
    let unique = S.toList (S.fromList a)
    if length unique <= k then
        solve unique n k
    else
        print $ -1

main = do
    t <- getLine
    handle_test $ read t

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

printList :: [Int] -> Int -> IO()
printList _ 0  = do putStr "\n"
printList list n = do
    putStr $ ( ++ " ") . unwords $  map show list
    printList list  $ n - 1

solve :: [Int] -> Int -> Int -> IO ()
solve unique n k = do
    print $ n * k
    printList unique' n
    where
        high = last unique
        len = length unique
        unique' = unique ++  [x * high | x <- [1 .. len - k]]

readInts :: IO [Int]
readInts = do
    input <- getLine
    return $ map read . words $ input

handle_test :: Int -> IO()
handle_test 0 = do return ()
handle_test t =  do
    [n, k] <- readInts
    a <- readInts
    let unique = S.toList (S.fromList a)
    if length unique <= k then
        solve unique n k
    else
        print $ -1
    handle_test $ t - 1

main = do
    t <- getLine
    handle_test $ read t

import qualified Data.List as L

solve :: Int -> Int -> [Int] -> [Int]
solve n k as
    | uniqueSize > k     = []
    | otherwise = take (n*k) $ L.cycle block
    where
        unique = map head $ L.group $ L.sort as
        uniqueSize = length unique
        block = L.replicate (k-uniqueSize) 0 ++ unique

testCases :: Int -> IO ()
testCases 0 = return ()
testCases t = do
    (n:k:_) <- readInts
    as <- readInts
    printSolution $ solve n k as
    testCases (t-1)

printSolution :: [Int] -> IO ()
printSolution [] = putStrLn "-1"
printSolution bs = do
    print $ length bs
    putStrLn $ unwords $ map show bs

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

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


You are given an integer $$$x$$$ of $$$n$$$ digits $$$a_1, a_2, \ldots, a_n$$$, which make up its decimal notation in order from left to right.Also, you are given a positive integer $$$k < n$$$.Let's call integer $$$b_1, b_2, \ldots, b_m$$$ beautiful if $$$b_i = b_{i+k}$$$ for each $$$i$$$, such that $$$1 \leq i \leq m - k$$$.You need to find the smallest beautiful integer $$$y$$$, such that $$$y \geq x$$$.

The first line of input contains two integers $$$n, k$$$ ($$$2 \leq n \leq 200\,000, 1 \leq k < n$$$): the number of digits in $$$x$$$ and $$$k$$$. The next line of input contains $$$n$$$ digits $$$a_1, a_2, \ldots, a_n$$$ ($$$a_1 \neq 0$$$, $$$0 \leq a_i \leq 9$$$): digits of $$$x$$$.

In the first line print one integer $$$m$$$: the number of digits in $$$y$$$. In the next line print $$$m$$$ digits $$$b_1, b_2, \ldots, b_m$$$ ($$$b_1 \neq 0$$$, $$$0 \leq b_i \leq 9$$$): digits of $$$y$$$.

getPair :: String -> (Int, Int)
getPair s = let x:y:_ = map read $ words s in (x, y)

toI :: String -> Integer
toI = read

solve :: Int -> Int -> String -> String
solve n k s = sol where
    prefix = take k s
    incPref = take k $ show $ (toI prefix) + 1
    candidate1 = toI $ take n $ cycle prefix
    candidate2 = toI $ take n $ cycle incPref
    candidate3 = toI $ take (n+1) $ cycle incPref
    candidates = [candidate1, candidate2, candidate3]
    sol = show $ head $ dropWhile (<(toI s)) $ candidates

main = do
    l1 <- getLine
    s <- getLine
    let (n, k) = getPair l1
    let sol = solve n k s
    putStrLn $ show $ length sol
    putStrLn sol

getPair :: String -> (Int, Int)
getPair s = let x:y:_ = map read $ words s in (x, y)

toI :: String -> Integer
toI = read

solve :: Int -> Int -> String -> String
solve n k s = sol where
    prefix = take k s
    incPref = take k $ show $ (toI prefix) + 1
    candidate1 = toI $ take n $ cycle prefix
    candidate2 = toI $ take n $ cycle incPref
    candidate3 = toI $ take (n+1) $ cycle incPref
    candidates = [candidate1, candidate2, candidate3]
    sol = show $ head $ dropWhile (<(toI s)) $ candidates

main = do
    l1 <- getLine
    s <- getLine
    let (n, k) = getPair l1
    let sol = solve n k s
    putStrLn sol