import Control.Applicative
import Data.Array

main :: IO ()
main = do
  size <- map read . words <$> getLine
  grid <- lines <$> getContents
  putStrLn $ solve size grid

solve :: [Int] -> [[Char]] -> String
solve [n, m] grid
  | and [withinOne a b | a <- edges, b <- edges] = "YES"
  | otherwise = "NO"
  where
  array = listArray (0, n-1) $ map (listArray (0, m-1)) grid
  isBlack i j = array ! i ! j == 'B'
  edges = [(i, j) | i <- [0..n-1],
    let js = [j | j <- [0..m-1], isBlack i j],
    j <- if null js then [] else [minimum js, maximum js]]
  withinOne (x, y) (z, w) =
    and [isBlack x j | j <- [y..w]] && and [isBlack i w | i <- [x..z]] ||
    and [isBlack z j | j <- [y..w]] && and [isBlack i y | i <- [x..z]]

import Control.Applicative
import Data.Array

main :: IO ()
main = do
  size <- map read . words <$> getLine
  grid <- lines <$> getContents
  putStrLn $ solve size grid

solve :: [Int] -> [[Char]] -> String
solve [n, m] grid
  | and [withinOne a b | a <- edges, b <- edges] = "YES"
  | otherwise = "NO"
  where
  array = listArray (0, n-1) $ map (listArray (0, m-1)) grid
  isBlack i j = array ! i ! j == 'B'
  edges = [(i, j) | i <- [0..n-1], j <- [0..m-1], isBlack i j,
    i == 0 || i == n-1 || j == 0 || j == m-1 ||
    or [not $ isBlack x y | (x, y) <- [(i-1, j), (i+1, j), (i, j-1), (i, j+1)]]]
  withinOne (x, y) (z, w) =
    and [isBlack x j | j <- [y..w]] && and [isBlack i w | i <- [x..z]] ||
    and [isBlack z j | j <- [y..w]] && and [isBlack i y | i <- [x..z]]


{-# 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


{-# 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)


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

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


{-- 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 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 $ 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 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


module Main where

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

type Maze = [[Char]]

allOff :: [Char] -> Bool
allOff = all (== '0')

completed :: Maze -> Bool
completed [] = True
completed (m:ms) = allOff m && completed ms

solve :: Maze -> Int
solve maze = go (0, width - 1) (reverse maze)
    where width = length $ head maze
          go (tl, tr) maze@(m:ms)
              | completed maze = min tl tr
              | allOff m       = go (tl + 1, tr + 1) ms
              | completed ms   = min (tl + maxOn) (tr + minOn)
              | otherwise      = go (tl' + 1, tr' + 1) ms
              where ons = elemIndices '1' m
                    minOn = width - minimum ons - 1
                    maxOn = maximum ons
                    tl' = min (tl + 2 * maxOn) (tr + width - 1)
                    tr' = min (tr + 2 * minOn) (tl + width - 1)

test0 = [ "0010"
        , "0100"
        ]
test1 = [ "001000"
        , "000010"
        , "000010"
        ]
test2 = [ "01110"
        , "01110"
        , "01110"
        , "01110"
        ]

main :: IO ()
main = do
  [n, _] <- map read . words <$> getLine
  maze <- replicateM n getLine
  print $ solve maze

{-# LANGUAGE BangPatterns #-}
module Main where
import qualified Data.ByteString.Char8 as B
import Control.Monad
import Control.Applicative
import Data.Maybe
import Data.List

readInt = maybe undefined fst . B.readInt
readInts = (readInt <$>) . B.words

solve m = (\(c, _, _) -> c) . foldl' go (0, 0, 1000)
  where
    go (!t, !tl, !tr) f = case ixs of
      [] -> (t, tl + 1, tr + 1)
      _ -> (min (tl + r) (tr + m + 1 - l), min (tl + 2*r + 1) (tr + m + 2), min (tr + 2*(m + 1 - l) + 1) (tl + m + 2))
      where
        ixs = elemIndices '1' f
        l = head ixs
        r = last ixs

main = do
  n:m:_ <- readInts <$> B.getLine
  b <- reverse <$> replicateM n getLine
  print $ solve m b

module Main where
import qualified Data.ByteString.Char8 as B
import Control.Monad
import Control.Applicative
import Data.Maybe
import Data.List

readInt = maybe undefined fst . B.readInt
readInts = (readInt <$>) . B.words

last' [] = Nothing
last' xs@(_:_) = Just $ last xs

lastIx = (last' .) . elemIndices

solve m r b
  | all (== '0') (concat b) = 0
  | otherwise = solve' m r b

solve' m r (l1':rest) = case rest of
  [] -> ix
  [l2] -> if all (== '0') l2 then ix else time
  _ -> time
  where
    ix = fromMaybe 0 $ lastIx '1' (if r then reverse l1' else l1')
    time
      | ix > (m + 2) `div` 2 = m + 2 + solve m (not r) rest
      | otherwise = 2 * ix + 1 + solve m r rest

main = do
  n:m:_ <- readInts <$> B.getLine
  b <- reverse <$> replicateM n getLine
  print $ solve m False b

module Main where
import qualified Data.ByteString.Char8 as B
import Control.Monad
import Control.Applicative
import Data.Maybe
import Data.List

readInt = maybe undefined fst . B.readInt
readInts = (readInt <$>) . B.words

last' [] = Nothing
last' xs@(_:_) = Just $ last xs

solve m r [l1, l2] = (\p -> if d then p else if p > (m + 2) `div` 2 then  m + 2 + solve m (not r) [l2] else  2*p + 1 + solve m r [l2]) $ fromMaybe 0 $ last' $ elemIndices '1' (if r then reverse l1 else l1)
  where d = all (== '0') l2

solve m r (l1:l2:ls) = (\p -> if p > (m + 2) `div` 2 then  m + 2 + solve m (not r) (l2 : ls) else  2*p + 1 + solve m r (l2 : ls)) $ fromMaybe 0 $ last' $ elemIndices '1' (if r then reverse l1 else l1)

solve _ r [l1] =  fromMaybe 0 $ last' $ elemIndices '1' (if r then reverse l1 else l1)

main = do
  n:m:_ <- readInts <$> B.getLine
  b <- reverse <$> replicateM n getLine
  print $ solve m False b

{-# LANGUAGE BangPatterns #-}
module Main where
import qualified Data.ByteString.Char8 as B
import Control.Monad
import Control.Applicative
import Data.Maybe
import Data.List

readInt = maybe undefined fst . B.readInt
readInts = (readInt <$>) . B.words

solve m = (\(c, _, _) -> c) . foldl' go (0, 0, 1000)
  where
    go (!t, !tl, !tr) f = case ixs of
      [] -> (t, tl + 1, tr + 1)
      _ -> (min (tl + r) (tr + m + 1 - l), min (tl + 2*r + 1) (tr + m + 2), min (tr + 2*(m + 1 - l)) (tl + m + 2))
      where
        ixs = elemIndices '1' f
        l = head ixs
        r = last ixs

main = do
  n:m:_ <- readInts <$> B.getLine
  b <- reverse <$> replicateM n getLine
  print $ solve m b


{-# LANGUAGE BangPatterns #-}
import Data.Int (Int64)
import Data.Foldable (foldl')
import Control.Applicative ((<$>))
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C

solve :: String -> Int64
solve line = foldr (*:) 1 . take n $ repeat k
    where
    n = length line
    (*:) !i !j = (i * j) `mod` 1000000007

    cnt = (\(i, j, k, l) -> [i, j, k, l]) $ foldl' count (0, 0, 0, 0) line
        where
        count (!i, !j, !k, !l) 'A' = (i + 1, j, k, l)
        count (!i, !j, !k, !l) 'C' = (i, j + 1, k, l)
        count (!i, !j, !k, !l) 'G' = (i, j, k + 1, l)
        count (!i, !j, !k, !l) 'T' = (i, j, k, l + 1)

    k = foldr (\i acc -> if i == m then acc + 1 else acc) 0 cnt
        where m = maximum cnt

main = do
    B.getLine
    line <- B.getLine
    print . solve . C.unpack $ C.init line

import Data.List

modulo :: Integer
modulo = 1000 * 1000 * 1000 + 7

powerMod :: Integer -> Integer -> Integer -> Integer
powerMod base 0 _ = 1
powerMod base exp modulo
    | exp `mod` 2 == 1 = base * powerMod base (exp - 1) modulo `mod` modulo
    | otherwise =
        let halfPow = powerMod base (exp `div` 2) modulo
        in
            halfPow * halfPow `mod` modulo

count :: Char -> String -> Int
count c str = length $ filter (== c) str

main = do
    getLine
    s <- getLine
    let frequences = [count 'A' s, count 'C' s, count 'T' s, count 'G' s]
    let max = maximum frequences
    let cntMax = length $ filter(== max) frequences
    putStrLn $ show $
        powerMod (fromIntegral cntMax) (fromIntegral (length s)) modulo

import Data.List (genericLength)
solve :: [Int] -> String -> Integer
solve ks [] = mod (g ^ sum ks) (10 ^ 9 + 7)
    where m = maximum ks
          g = genericLength $ filter (==m) ks
solve [a, c, g, t] (x:xs) = case x of
    'A' -> solve [a + 1, c, g, t] xs
    'C' -> solve [a, c + 1, g, t] xs
    'G' -> solve [a, c, g + 1, t] xs
    'T' -> solve [a, c, g, t + 1] xs
main = getLine >> getLine >>= putStrLn . show . solve [0, 0, 0, 0]


solveTask :: (Integer, Integer) -> Integer
solveTask (a, b) =
    let d = length $ show $ b
        d' = length $ show $ b + 1
    in if d == d'
          then a * toInteger(d-1)
          else a * toInteger(d)

groupTaskInput :: [String] -> [(Integer, Integer)]
groupTaskInput [] = []
groupTaskInput (n:(d:xs)) = (read n, read d) : groupTaskInput(xs)

makeTaskInput :: String -> [(Integer, Integer)]
makeTaskInput s = groupTaskInput . tail . words $ s

solve :: String -> String
solve s = concat $ (map (++ "\n") ) $ (map $ show.solveTask) $ makeTaskInput s

main' :: IO ()
main' = do interact $ solve

main = main'

import Data.Ord
import Data.Int
import Data.Sequence as DSeq (null, Seq( Empty ), (|>), (><), replicate)
import Data.Foldable
import Data.List
import Data.Maybe
import Data.Either
import Data.Array.ST.Safe
import Data.Array.Unboxed
import Control.Monad
import Control.Monad.ST.Safe
import Control.Monad.Trans.Except
import Control.Monad.Trans.Class
import Prelude hiding (showList)
import Text.Read (readEither)

getToken :: IO String
getToken =
    let aux s = do
        x <- getChar
        if x == ' ' || x == '\t' || x == '\n' then
            if DSeq.null s then
                aux s
            else
                return $ toList s
        else
            aux $ s |> x
    in aux DSeq.Empty

type EIO a = ExceptT String IO a

get :: Read a => EIO a
get = ExceptT $ liftM readEither getToken
puts :: String -> EIO ()
puts = lift . putStr
putsln :: String -> EIO ()
putsln = lift . putStrLn
put :: Show a => a -> EIO ()
put = putsln . show
putln :: Show a => a -> EIO ()
putln = putsln . show
showList :: Show a => [a] -> String
showList [] = []
showList (x : l) = shows x $ showChar ' ' $ showList l

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

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

f1 :: EIO ()
f1 = do
    (a, b) <- liftM2 (,) get get :: EIO (Int64, Int64)
    putln $ f2 a b

f2 :: Int64 -> Int64 -> Int64
f2 a b = (*) a $ log10 $ (+) b 1

log10 :: Int64 -> Int64
log10 n = if n <= 9 then 0 else (+) 1 $ log10 $ div n 10

import System.IO
-- import Prelude

readInt :: IO Int
readInt = readLn

castToInteger x = read x::Integer

main = do
    t <- readInt
    mainLoop t

mainLoop t = do
    if t == 0 then
        return ()
    else do
        line <- getLine
        let test_case = (map castToInteger . take 2 . words) line

        solveTask test_case

        mainLoop (t - 1)

solveTask :: [Integer] -> IO ()
solveTask [a, b] = do
    let bs = [10^i - 1| i <- [1..11], 10^i - 1 <= b]
    let res = a * count bs
    print res

count :: [Integer] -> Integer
count [] = 0
count (x:xs) = 1 + count xs

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

main = getLine >> getContents >>= putStrLn.unlines.map (show.(\(a:b:_) -> a * (toInteger $ pred $ length $ show $ succ b)).map read.words).lines

-- ayy it's a one-liner

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

main = getLine >> getContents >>= putStrLn.unlines.map (show.(\(a:b:_) -> a * (pred $ length $ show $ succ b)).map read.words).lines

-- ayy it's a one-liner

import System.IO
-- import Prelude

readInt :: IO Int
readInt = readLn

readTuple :: IO (Int, Int)
readTuple = readLn

castToInt x = read x::Int

main = do
    t <- readInt
    mainLoop t

mainLoop t = do
    if t == 0 then
        return ()
    else do
        line <- getLine
        let test_case = (map castToInt . take 2 . words) line

        solveTask test_case

        mainLoop (t - 1)

solveTask [a, b] = do
    let bs = [10^i - 1| i <- [1..10], 10^i - 1 <= b]
    let res = a * count bs
    print res

count [] = 0
count (x:xs) = 1 + count xs


main=interact$q"$"
q p(x:s)|x==head p=q(tail p)s|1<2=q(x:p)s
q p _=reverse$init p

solve s = solve' s []
	where
		solve' [] stack = reverse stack
		solve' (x:xs) stack
			| not (null stack) && head stack == x = solve' xs $ tail stack
			| otherwise =  solve' xs $ x:stack

main = interact solve

import Data.List

solve :: String -> String -> String
solve [] acc = acc
solve (x:xs) (a:as) | x == a = solve xs as
solve (x:xs) acc = solve xs (x:acc)

-- xraccabccbry

main = do
    stuff <- getLine
    putStrLn $ reverse $ solve stuff ""

--import CPUTime

bigWord :: String
bigWord = take 100000 (cycle "ab") ++ (take 100000 (cycle "ba")) ++ "c"

solve :: String -> String -> String
solve [] s = s
solve (x:xs) [] = solve xs [x]
solve (x:xs) (y:ys) = if x == y then solve xs ys else solve xs (x:y:ys)

main = do
    s <- getLine
--    let s = bigWord
--    t0 <- getCPUTime
    putStrLn (reverse (solve s ""))
--    t1 <- getCPUTime
--    putStrLn (show (fromInteger (t1 - t0) * 1e-012) ++ " sec.")

solve xs = solve' xs []
  where solve' xs (s1:s2:stack) | s1 == s2 = solve' xs stack
        solve' (x:xs) stack = solve' xs (x:stack)
        solve' [] stack = reverse stack

main = do line <- getLine
          putStrLn $ solve line

main=interact g
g (a:b:s)|a==b=g s
 |null t=[]
 |a==head t=tail t
 |0<1=a:t
 where t=g(b:s)
g a=a

main :: IO ()
main = putStrLn . solve =<< getLine

solve :: String -> String
solve = reverse . foldl go ""
  where
    go (y:ys) x | x == y = ys
    go ys x = x : ys

main = putStrLn . solve [] =<< getLine
solve [] (y:ys) = solve [y] ys
solve (x:xs) (y:ys) | x == y    = solve xs ys
                    | otherwise = solve (y:x:xs) ys
solve xs [] = reverse xs

main = getLine >>= putStrLn . solve

solve = reverse . foldl f ""
f (y:ys) x | x==y = ys
f ys x = x:ys

f (s:ss) (b, (r:rs), dir) | s==r = f ss (b, rs, dir)
                          | otherwise = f ss (b, (s:r:rs), dir)
f (s:ss) (b, rs, dir) = f ss (b, (s:rs), dir)
f [] (True, (r:rs), dir) = f [r] (False, rs, not dir)
f [] (b, [], dir) = []
f [] (False, r, True) = reverse r
f [] (False, r, False) = r
main = do
    l <- getLine
    putStrLn $ f (tail l) (False, [head l], True)

proc' line = proc [] line

proc h [] = reverse h
proc [] [] = []
proc [] (a:xs) = proc [a] xs
proc (a:xs) (b:ys) =
  if a==b then
    proc xs ys
  else
    proc (b:a:xs) ys

main = do
  line <- getLine
  putStrLn(proc' line)

g(o:p)(a:b)|a==o=g p b|1>0=g(a:o:p)b
g l r=reverse l
main=interact$g" "

solve [] = []
solve (a:b:t) | a==b = solve t
solve (a:t) =
    let t' = solve t
    in case t' of
        [] -> [a]
        (b:t) | a==b -> t
        _ -> a:t'

main = interact solve

main = interact solve
solve x = check x []
check [] x = reverse x
check (x:xs) [] = check xs [x]
check (x:xs) (y:ys) = if x==y then check xs ys else check xs (x:y:ys)

main=interact$q"$"
q p(x:s)|x==head p=q(tail p)s
        |1<2=q(x:p)s
q p _=reverse$init p

main=interact$q"$"
q(h:p)(x:s)|x==h=q p s|1<2=q(x:h:p)s
q p _=reverse$init p

main = putStrLn . solve "$" =<< getLine

solve ps (x:xs) | x == head ps = solve (tail ps) xs
                | otherwise    = solve (x : ps) xs
solve ps _ = reverse $ init ps

main=interact$q" "
q(h:p)(x:s)|x==h=q p s|1<2=q(x:h:p)s
q p _=reverse p

main=interact$q" "
q(h:p)(x:s)|x==h=q p s|1<2=q(x:h:p)s
q p _=reverse$p

main=putStr.q"$"=<<getLine
q p(x:s)|x==head p=q(tail p)s
        |1<2=q(x:p)s
q p _=reverse$init p

module Main where

main = do
    str <- getLine
    putStrLn $ shrink str

shrink (s1:ss) =
    case shrink ss of
        s@(s2:ss) -> if s1 == s2
            then ss
            else s1:s
        s -> s1:s
shrink s = s

solve ys [] = ys
solve [] (x:xs) = solve [x] xs
solve (y:ys) (x:xs)
	| x == y = solve ys xs
	| otherwise = solve (x:y:ys) xs

main = getLine >>= putStrLn . reverse . solve []

fix rest [] = reverse rest
fix rest (x:[]) = fix (x:rest) []
fix [] (x:y:xs)
    | x == y    = fix [] xs
    | otherwise = fix [x] (y:xs)
fix rest (x:y:xs)
    | x == y    = fix (tail rest) ((head rest):xs)
    | otherwise = fix (x:rest) (y:xs)

main :: IO ()
main = do
    seq <- getLine
    putStr (fix [] seq)

import Data.List
main=interact g
g s|s==w=s
 |0<1=g w
 where w=map head.filter((==1).length).group$s

main :: IO ()
main = putStrLn . solve =<< getLine

solve :: String -> String
solve = fixed . iterate go
  where go (x:yxs@(y:xs)) | x == y = go (dropWhile (==x) xs)
                          | otherwise = x : go yxs
        go xs = xs

fixed :: Eq a => [a] -> a
fixed (x0:xs@(x1:_)) | x0 == x1 = x0
                     | otherwise = fixed xs
fixed [x] = x
fixed _ = error "fixed: empty list"

main :: IO ()
main = putStrLn . solve =<< getLine

solve :: String -> String
solve = fixed . iterate go
  where go (x:yxs@(y:xs)) | x == y = go $ dropWhile (==x) xs
                          | otherwise = x : go yxs
        go xs = xs

fixed :: Eq a => [a] -> a
fixed (x0:xs@(x1:_)) | x0 == x1 = x0
                     | otherwise = fixed xs
fixed [x] = x
fixed _ = error "fixed: empty list"


import Data.Graph
import Control.Applicative
import Control.Monad

main = do
    [n,m] <- map read . words <$> getLine
    ts <- map (toTuple . map read . words) <$> replicateM m getLine
    let graph = buildG (1,n) ts
    putStrLn . unwords . map show . reverse . topSort $ graph

toTuple [x,y] = (x,y)

import Data.Graph

strToList = (map (read :: String -> Vertex)).words

main = do
    s <- getLine
    let [n, m] = strToList s
    t <- getContents
    putStrLn $ unwords $ map show $ reverse $ topSort $ buildG (1, n) (map (\[a, b] -> (a, b)) (map strToList (lines t)))

import Data.Graph
import Control.Applicative
import Control.Monad

main = do
    [n,m] <- map read . words <$> getLine
    ts <- map (toTuple . map read . words) . lines <$> getContents
    let graph = buildG (1,n) ts
    putStrLn . unwords . map show . reverse . topSort $ graph

toTuple [x,y] = (x,y)

import Data.Graph
import Control.Applicative
import Control.Monad

main = do
    [n,m] <- map read . words <$> getLine
    ts <- map (toTuple . map read . words) . lines <$> getLine
    let graph = buildG (1,n) ts
    putStrLn . unwords . map show . reverse . topSort $ graph

toTuple [x,y] = (x,y)