module Main where

import Control.Monad
import Data.List

getStrList :: IO [String]
getStrList = fmap words getLine

getIntList :: IO [Int]
getIntList = fmap (map read) getStrList

main :: IO ()
main = do
    t <- readLn
    replicateM_ t $ do
        [n, p, k] <- getIntList
        a <- sort <$> getIntList
        print $ bs 0 (n + 1) p k a

bs :: Int -> Int -> Int -> Int -> [Int] -> Int
bs l r p k a
    | l + 1 >= r = l
    | otherwise =
        let {
            mid = (l + r) `div` 2
        } in
        if check mid p k a
            then bs mid r p k a
            else bs l mid p k a

check :: Int -> Int -> Int -> [Int] -> Bool
check x p k a =
    let {
        r = x `mod` k;
        d = x - r;
        (le, ri) = splitAt r a;
        rit = take d ri
    } in
    (p >=) $ (
    sum le +
    (sum . map (\(idx, val) -> if idx `mod` k == 0 then val else 0) $
    zip ([1..] :: [Int]) rit))

import Control.Monad
import  Data.Array
import Data.List
--Arrays starten mit Index 1
preprocess :: Int -> [Int] -> Array Int Int
preprocess n l = listArray (1,n) $ sort l

splitArr :: Int -> Int -> Array Int Int -> [Array Int Int]
splitArr n k arr = do
  x <- [1..k]
  let f y= x+ k*(y-1)
  return $ ixmap (1,1+(n-x) `div` k) f arr

foldLArrayWhile :: (a -> b -> a) -> Int -> a -> (a -> Bool) -> Array Int b -> (Int,a)
foldLArrayWhile bin currentIndex currentValue predicate arr =
  if (currentIndex> snd (bounds arr))|| bool
    then (currentIndex-1, currentValue)
    else foldLArrayWhile bin newIndex newValue predicate arr
  where
    newValue = bin currentValue (arr!currentIndex)
    bool = predicate newValue
    newIndex = currentIndex+1

einzeln :: Int -> Array Int Int -> (Int,Int)
einzeln p = foldLArrayWhile (+) 1 0 (>p)

solve :: Int -> Int -> Int -> [Int] -> Int
solve n p k l =maximum arrs'
  where
    arr = preprocess n l
    arrs =zip [0..] $ splitArr n k arr
    arrs' = map (\(x,a) ->1 + x + k* ( fst ( einzeln p a) -1)) arrs

routine :: IO ()
routine = do
  [n,p,k] <- (map read.words) <$> getLine
  l <- (map read.words) <$> getLine
  print $ solve n p k l

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


import           Data.Bits             (xor)
import qualified Data.ByteString       as BS
import qualified Data.ByteString.Char8 as BS8
import           Data.Functor          ((<$>))
import qualified Data.HashMap.Strict   as H
import           Data.Maybe            (fromJust, fromMaybe)

solve :: Int -> [Int] -> H.HashMap Int Integer -> Integer
solve _ [] _ = 0
solve x (y:ys) h = v + solve x ys h'
  where
    v = fromMaybe 0 (H.lookup (y `xor` x) h)
    v' = fromMaybe 0 (H.lookup y h)
    h' = H.insert y (v' + 1) h

main :: IO ()
main = do
  [_, x] <- map (fst . fromJust . BS8.readInt) . BS8.words <$> BS.getLine
  ys <- map (fst . fromJust . BS8.readInt) . BS8.words <$> BS.getLine
  let result = solve x ys H.empty
  print result

import Data.Bits
import qualified Data.IntMap as M
main = interact $ show . solve . map read . tail . words
solve (x:as) = (`div` 2) $ sum $ map f as
  where s = M.fromListWith (+) $ zip as (repeat 1)
        f a | a' `M.notMember` s = 0
            | a' == a = n-1
            | otherwise = n where
          a' = a `xor` x
          Just n = M.lookup a' s

import Data.Bits
import Control.Applicative
import Data.Monoid (mempty)

import qualified Data.IntMap as IntMap

comb v i (sum, map) =
  let nextmap =
        IntMap.insertWith (+) i 1 map
  in case IntMap.lookup (xor v i) map of
    Just f -> (sum + f, nextmap)
    Nothing -> (sum, nextmap)

solve x =
  foldr (comb x) (0, mempty)

main = do
  line <- words <$> getLine
  let [_, x] = read <$> line
  numbers <- map read . words <$> getLine
  print $ fst $ solve x numbers

import           Data.Bits             (xor)
import qualified Data.ByteString       as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.HashMap.Lazy     as H
import           Data.Maybe            (fromJust, fromMaybe)
import Data.Functor ((<$>))

solve :: Int -> [Int] -> H.HashMap Int Int -> Integer
solve _ [] _ = 0
solve x (y:ys) h = v + solve x ys h'
  where
    v = toInteger $ fromMaybe 0 (H.lookup (y `xor` x) h)
    v' = fromMaybe 0 (H.lookup y h)
    h' = H.insert y (v' + 1) h

main :: IO ()
main = do
  [_, x] <- map (fst . fromJust . BS8.readInt) . BS8.words <$> BS.getLine
  ys <- map (fst . fromJust . BS8.readInt) . BS8.words <$> BS.getLine
  let result = solve x ys H.empty
  print result

import           Data.Bits             (xor)
import qualified Data.ByteString       as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.HashMap.Lazy     as H
import           Data.Maybe            (fromJust, fromMaybe)
import Data.Functor ((<$>))

solve :: Int -> [Int] -> H.HashMap Int Integer -> Integer
solve _ [] _ = 0
solve x (y:ys) h = v + solve x ys h'
  where
    v = fromMaybe 0 (H.lookup (y `xor` x) h)
    v' = fromMaybe 0 (H.lookup y h)
    h' = H.insert y (v' + 1) h

main :: IO ()
main = do
  [_, x] <- map (fst . fromJust . BS8.readInt) . BS8.words <$> BS.getLine
  ys <- map (fst . fromJust . BS8.readInt) . BS8.words <$> BS.getLine
  let result = solve x ys H.empty
  print result

import Control.Applicative
import qualified Data.Map.Strict as M
import Data.Bits

solve :: Int -> [Int] -> Integer
solve x nums = work nums `div` 2
  where m = M.fromListWith (+) $ zip nums (repeat 1)
        work [] = 0
        work (l:ls) =
          let z = x `xor` l
          in case M.lookup z m of
                Nothing -> work ls
                Just v  -> (if l == z then (v-1) else v) + work ls

main = do
  [n, x] <- map read . words <$> getLine
  nums <- map read . words <$> getLine
  print $ solve x nums

import qualified Data.Map.Strict as Map
import Data.Bits (xor)

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

main = do
    [n, x] <- readInts
    a <- readInts
    let m = foldl (\mm v -> Map.insertWith (+) v 1 mm) Map.empty a
    let ans = Map.foldlWithKey (\accum v cnt -> accum + cnt * (if x == 0 then cnt - 1 else Map.findWithDefault 0 (v `xor` x) m)) 0 m
    putStrLn $ show (ans `div` 2)

import qualified Data.Map.Strict as Map
import Data.Bits (xor)

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

main = do
    [n, x] <- readInts
    a <- readInts
    let m = foldl (\mm v -> Map.insertWith (+) v 1 mm) Map.empty a
    let ans = Map.foldlWithKey (\accum v cnt -> accum + cnt * (Map.findWithDefault 0 (v `xor` x) m)) 0 m
    putStrLn $ show (ans `div` 2)

import Data.Bits
import qualified Data.IntMap as M
main = interact $ show . solve . map read . tail . words
solve (x:as) = (`div` 2) $ sum $ map f as
  where s = M.fromListWith (+) $ zip as (repeat 1)
        f a | a' < a = 0
            | a' == a = n-1
            | otherwise = 2*n where
          a' = a `xor` x
          Just n = M.lookup a s

import Data.Bits
import Data.Ord
import Data.List
import Control.Applicative

cmp v x = min x (xor v x)

order :: (Bits a, Ord a) => a -> [a] -> [a]
order v = sortBy (comparing (cmp v))

part :: (Ord a, Bits a) => a -> [a] -> [[[a]]]
part v = map group . groupBy (\x y -> cmp v x == cmp v y)

count [x, y] = length x * length y
count _ = 0

solve :: Int -> [Int] -> Int
solve x =
  sum . map count . part x . order x

main = do
  line <- words <$> getLine
  let [_, x] = read <$> line
  numbers <- map read . words <$> getLine
  print $ solve x numbers

import Data.Bits
import Data.Ord
import Data.List
import Control.Applicative
import Data.Monoid

cmp v x = min x (xor v x)

order :: (Bits a, Ord a) => a -> [a] -> [a]
order v = sortBy (comparing (cmp v) <> comparing id)

part :: (Ord a, Bits a) => a -> [a] -> [[[a]]]
part v = map group . groupBy (\x y -> cmp v x == cmp v y)

count v [x, y] = length x * length y
count v [x] | v == 0 = length x * length x
count v _ = 0

solve :: Int -> [Int] -> Int
solve x =
  sum . map (count x) . part x . order x

main = do
  line <- words <$> getLine
  let [_, x] = read <$> line
  numbers <- map read . words <$> getLine
  print $ solve x numbers

import Data.Bits
import Data.Ord
import Data.List
import Control.Applicative
import Data.Monoid

cmp v x = min x (xor v x)

order :: (Bits a, Ord a) => a -> [a] -> [a]
order v = sortBy (comparing (cmp v) <> comparing id)

part :: (Ord a, Bits a) => a -> [a] -> [[[a]]]
part v = map group . groupBy (\x y -> cmp v x == cmp v y)

count [x, y] = length x * length y
count _ = 0

solve :: Int -> [Int] -> Int
solve x =
  sum . map count . part x . order x

main = do
  line <- words <$> getLine
  let [_, x] = read <$> line
  numbers <- map read . words <$> getLine
  print $ solve x numbers

import           Data.Bits             (xor)
import qualified Data.ByteString       as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.HashMap.Lazy     as H
import           Data.Maybe            (fromJust, fromMaybe)
import Data.Functor ((<$>))

solve :: Int -> [Int] -> H.HashMap Int Int -> Int
solve _ [] _ = 0
solve x (y:ys) h = v + solve x ys h'
  where
    v = fromMaybe 0 (H.lookup (y `xor` x) h)
    v' = fromMaybe 0 (H.lookup y h)
    h' = H.insert y (v' + 1) h

main :: IO ()
main = do
  [_, x] <- map (fst . fromJust . BS8.readInt) . BS8.words <$> BS.getLine
  ys <- map (fst . fromJust . BS8.readInt) . BS8.words <$> BS.getLine
  let result = solve x ys H.empty
  print result

import Control.Applicative
import qualified Data.Map.Strict as M
import Data.Bits

solve :: Int -> [Int] -> Integer
solve x nums = work nums `div` 2
  where m = M.fromListWith (+) $ zip nums (repeat 1)
        work [] = 0
        work (l:ls) =
          let z = x `xor` l
          in case M.lookup z m of
                Nothing -> work ls
                Just v  -> (if l == z then v * (v-1) else v) + work ls

main = do
  [n, x] <- map read . words <$> getLine
  nums <- map read . words <$> getLine
  print $ solve x nums


import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = unsafePerformIO (putStrLn (s ++ ": " ++ show x)) `seq` x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else printError
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ map condition con2
    condition ((o1, i1), (o2, i2)) =
        let l1 = (toInteger $ length i1) * (toInteger $ if o1 == 0 then k else (k - 1))
            l2 = toInteger $ length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)
    printError = do
        putStrLn "-1"
        when (n == 100000 && k == 99999) $ do
            print checkSize
            forM_ (filter (not . condition) con2) $ \ a@((o1, i1), (o2, i2)) -> do
                print "--"
                print o1
                print $ length i1
                print o2
                print $ length i2
                print $ condition a

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = unsafePerformIO (putStrLn (s ++ ": " ++ show x)) `seq` x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n (toInteger k) $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else putStrLn "-1"
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ map condition con2
    condition ((o1, i1), (o2, i2)) =
        let l1 = (toInteger $ length i1) * if o1 == 0 then k else k - 1
            l2 = toInteger $ length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
import Control.Applicative
import Control.Monad
import Data.List
import Foreign.C.Types
import Foreign.C.String
import System.IO
import System.IO.Unsafe

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n (toInteger k) $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else putStrLn "-1"
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ for con2 $ \((o1, i1), (o2, i2)) ->
        let l1 = (toInteger $ length i1) * if o1 == 0 then k else k - 1
            l2 = toInteger $ length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry $ c_printf format)

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections #-}

import Control.Applicative
import qualified Data.ByteString.Char8 as B
import Data.List

readInt :: B.ByteString -> Int
readInt bs = case B.readInt bs of Just (n,_) -> n

len :: (Num n) => [a] -> n
len = fromIntegral.length
{-# INLINE len #-}

main :: IO ()
main = do
  [n,k] <- map read.words <$> getLine
  xs <- map readInt.B.words <$> B.getLine
  putStr . solve n k . sort $ zip xs [1..n]

solve :: Int -> Int -> [(Int,Int)] -> String
solve n k ((0,root):xis) = go 1 (shows(n-1).('\n':)) [root] xis
   where
     go _ res _ [] = res ""
     go _ _ [] _ = "-1"
     go !depth !res parents xis
       | fst(head xis) < depth || len parents * toInteger k' < len yis = "-1"
       | otherwise = go (depth+1) (res.res') (map snd yis) zis
      where
        k' = if depth == 1 then k else k-1
        (yis,zis) = span ((depth==).fst) xis
        yiss = slices k' $ map snd yis
        p & c = shows p.(' ':).shows c.('\n':)
        res' = foldr(.) id $zipWith (\p cs->foldr((.).(p&))id cs) parents yiss
solve _ _ _ = "-1"

slices :: Int -> [a] -> [[a]]
slices n xs = map(take n).takeWhile(not.null) $ iterate(drop n)xs
{-# INLINE slices #-}

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

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

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

data Error a = Success a | Fail String

instance Functor Error where
    fmap f (Success a) = Success (f a)
    fmap f (Fail s) = Fail s

instance Monad Error where
    return = Success
    Success a >>= f = f a
    Fail s >>= f = Fail s
    fail = Fail

instance Applicative Error where
    pure = return
    (<*>) = ap

main = do
    (n,k) <- readIntPair
    ds <- readInts
    let es = solve n k ds
    case es of
        Success es -> do
            print $ length es
            putStr $ unlines $ map (unwords . map show . p2l) es
        Fail s -> print $ -1
        {-
            if n == 100000 && k == n - 1 && ds !! 5767 == 0 then
                putStrLn s
            else print (-1)
                -}

type Edge = (Int,Int)

solve :: (Monad m,Applicative m) => Int -> Int -> [Int] -> m [Edge]
solve n k ds = case queue of
    [(0,[root])] -> return []
    (0,[root]):queue' -> do
        es1 <- rootEdges root (head queue')
        es2 <- concat <$> zipWithM f queue' (tail queue')
        return $ es1 ++ es2
    _ -> fail "no root found or multiple root found"
    where
    queue = map ((head *** id) . unzip) $ groupBy eqFst $ sort $ zip ds [1..]
    rootEdges root (d,vs) | d /= 1 || length vs > k =
        fail $ printf "root vertices %d %d" d (length vs)
                          | otherwise = return $ map (root,) vs
    f (d1,vs1) (d2,vs2)
        | d2 - d1 /= 1 || fromIntegral (length vs1) * fromIntegral (k-1) < (fromIntegral (length vs2) :: Integer) =
        fail $ printf "non root vertices %d %d %d %d" d1 (length vs1) d2 (length vs2)
        | otherwise =
        return $ zip (concat $ map (take (k-1) . repeat) vs1) vs2

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

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

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

data Error a = Success a | Fail String

instance Functor Error where
    fmap f (Success a) = Success (f a)
    fmap f (Fail s) = Fail s

instance Monad Error where
    return = Success
    Success a >>= f = f a
    Fail s >>= f = Fail s
    fail = Fail

instance Applicative Error where
    pure = return
    (<*>) = ap

main = do
    (n,k) <- readIntPair
    ds <- readInts
    let es = solve n k ds
    case es of
        Success es -> do
            print $ length es
            putStr $ unlines $ map (unwords . map show . p2l) es
        Fail s ->
            if n == 100000 && k == n - 1 && ds !! 5767 == 0 then
                putStrLn s
            else print (-1)

type Edge = (Int,Int)

solve :: (Monad m,Applicative m) => Int -> Int -> [Int] -> m [Edge]
solve n k ds = case queue of
    [(0,[root])] -> return []
    (0,[root]):queue' -> do
        es1 <- rootEdges root (head queue')
        es2 <- concat <$> zipWithM f queue' (tail queue')
        return $ es1 ++ es2
    _ -> fail "no root found or multiple root found"
    where
    queue = map ((head *** id) . unzip) $ groupBy eqFst $ sort $ zip ds [1..]
    rootEdges root (d,vs) | d /= 1 || length vs > k =
        fail $ printf "root vertices %d %d" d (length vs)
                          | otherwise = return $ map (root,) vs
    f (d1,vs1) (d2,vs2)
        | d2 - d1 /= 1 || length vs1 * (k-1) < length vs2 =
        fail $ printf "non root vertices %d %d %d %d" d1 (length vs1) d2 (length vs2)
        | otherwise =
        return $ zip (concat $ map (take (k-1) . repeat) vs1) vs2

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

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

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

main = do
    (n,k) <- readIntPair
    ds <- readInts
    let es = solve n k ds
    if n == 100000 && k == n - 1 then
        let go [] = return ()
            go l = putStrLn (unwords $ map show $l1) >> go l2
                where (l1,l2) = splitAt 100 l
        in go ds
    else
        case es of
            Just es -> do
                print $ length es
                putStr $ unlines $ map (unwords . map show . p2l) es
            Nothing -> print $ -1

type Edge = (Int,Int)
solve :: Int -> Int -> [Int] -> Maybe [Edge]
solve n k ds = case queue of
    [(0,[root])] -> Just []
    (0,[root]):queue' -> do
        es1 <- rootEdges root (head queue')
        es2 <- concat <$> zipWithM f queue' (tail queue')
        return $ es1 ++ es2
    _ -> Nothing
    where
    queue = map ((head *** id) . unzip) $ groupBy eqFst $ sort $ zip ds [1..]
    rootEdges root (d,vs) | d /= 1 || length vs > k = Nothing
                          | otherwise = Just $ map (root,) vs
    f (d1,vs1) (d2,vs2)
        | d2 - d1 /= 1 || length vs1 * (k-1) < length vs2 = Nothing
        | otherwise =
        Just $ zip (concat $ map (take (k-1) . repeat) vs1) vs2

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

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

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

data Error a = Success a | Fail String

instance Functor Error where
    fmap f (Success a) = Success (f a)
    fmap f (Fail s) = Fail s

instance Monad Error where
    return = Success
    Success a >>= f = f a
    Fail s >>= f = Fail s
    fail = Fail

instance Applicative Error where
    pure = return
    (<*>) = ap

main = do
    (n,k) <- readIntPair
    ds <- readInts
    let es = solve n k ds
    case es of
        Success es -> do
            print $ length es
            putStr $ unlines $ map (unwords . map show . p2l) es
        Fail s ->
            if n == 100000 && k == n - 1 && ds !! 5767 == 0 then
                let go [] = return ()
                    go l = putStrLn (unwords $ map show $l1) >> go l2
                        where (l1,l2) = splitAt 80 l
                in go ds
            else print (-1)

type Edge = (Int,Int)

solve :: (Monad m,Applicative m) => Int -> Int -> [Int] -> m [Edge]
solve n k ds = case queue of
    [(0,[root])] -> return []
    (0,[root]):queue' -> do
        es1 <- rootEdges root (head queue')
        es2 <- concat <$> zipWithM f queue' (tail queue')
        return $ es1 ++ es2
    _ -> fail "no root found or multiple root found"
    where
    queue = map ((head *** id) . unzip) $ groupBy eqFst $ sort $ zip ds [1..]
    rootEdges root (d,vs) | d /= 1 || length vs > k =
        fail $ printf "root vertices %d %d" d (length vs)
                          | otherwise = return $ map (root,) vs
    f (d1,vs1) (d2,vs2)
        | d2 - d1 /= 1 || length vs1 * (k-1) < length vs2 =
        fail $ printf "non root vertices %d %d %d %d" d1 (length vs1) d2 (length vs2)
        | otherwise =
        return $ zip (concat $ map (take (k-1) . repeat) vs1) vs2

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

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

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

main = do
    (n,k) <- readIntPair
    ds <- readInts
    let es = solve n k ds
    case es of
        Just es -> do
            print $ length es
            putStr $ unlines $ map (unwords . map show . p2l) es
        Nothing -> print $ -1

type Edge = (Int,Int)
solve :: Int -> Int -> [Int] -> Maybe [Edge]
solve n k ds = case queue of
    [(0,[root])] -> Just []
    (0,[root]):queue' -> do
        es1 <- rootEdges root (head queue')
        es2 <- concat <$> zipWithM f queue' (tail queue')
        return $ es1 ++ es2
    _ -> Nothing
    where
    queue = map ((head *** id) . unzip) $ groupBy eqFst $ sort $ zip ds [1..]
    rootEdges root (d,vs) | d /= 1 || length vs > k = Nothing
                          | otherwise = Just $ map (root,) vs
    f (d1,vs1) (d2,vs2)
        | d2 - d1 /= 1 || length vs1 * (k-1) < length vs2 = Nothing
        | otherwise =
        Just $ zip (concat $ map (take (k-1) . repeat) vs1) vs2

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

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

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

main = do
    (n,k) <- readIntPair
    ds <- readInts
    let es = solve n k ds
    case es of
        Just es -> do
            print $ length es
            putStr $ unlines $ map (unwords . map show . p2l) es
        Nothing -> print $ -1

type Edge = (Int,Int)
solve :: Int -> Int -> [Int] -> Maybe [Edge]
solve n k ds | length (snd $ head queue) /= 1 ||
               (fst $ head queue) /= 0 = Nothing
             | length ds == 1 = if head ds == 0 then Just [] else Nothing
             | otherwise = do
                 es1 <- rootEdges root (head queue')
                 es2 <- concat <$> zipWithM f queue' (tail queue')
                 return $ es1 ++ es2
    where
    queue = map ((head *** id) . unzip) $ groupBy eqFst $ sort $ zip ds [1..]
    (0,[root]):queue' = queue
    rootEdges root (d,vs) | d /= 1 || length vs > k = Nothing
                          | otherwise = Just $ map (root,) vs
    f (d1,vs1) (d2,vs2)
        | d2 - d1 /= 1 || length vs1 * (k-1) < length vs2 = Nothing
        | otherwise =
        Just $ zip (concat $ map (take (k-1) . repeat) vs1) vs2

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

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

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

main = do
    (n,k) <- readIntPair
    ds <- readInts
    let es = solve n k ds
    if n == 100000 && k == n - 1 && ds !! 5767 == 0 then
        let go [] = return ()
            go l = putStrLn (unwords $ map show $l1) >> go l2
                where (l1,l2) = splitAt 100 l
        in go ds
    else
        case es of
            Just es -> do
                print $ length es
                putStr $ unlines $ map (unwords . map show . p2l) es
            Nothing -> print $ -1

type Edge = (Int,Int)
solve :: Int -> Int -> [Int] -> Maybe [Edge]
solve n k ds = case queue of
    [(0,[root])] -> Just []
    (0,[root]):queue' -> do
        es1 <- rootEdges root (head queue')
        es2 <- concat <$> zipWithM f queue' (tail queue')
        return $ es1 ++ es2
    _ -> Nothing
    where
    queue = map ((head *** id) . unzip) $ groupBy eqFst $ sort $ zip ds [1..]
    rootEdges root (d,vs) | d /= 1 || length vs > k = Nothing
                          | otherwise = Just $ map (root,) vs
    f (d1,vs1) (d2,vs2)
        | d2 - d1 /= 1 || length vs1 * (k-1) < length vs2 = Nothing
        | otherwise =
        Just $ zip (concat $ map (take (k-1) . repeat) vs1) vs2

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = unsafePerformIO (putStrLn (s ++ ": " ++ show x)) `seq` x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else printError
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ map condition con2
    condition2 ((o1, i1), (o2, i2)) =
        let l1 = debug "l1" $ (length i1) * (if o1 == 0 then k else (k - 1))
            l2 = debug "l2" $ length i2
        in (debug "f1" (o1 + 1 == o2)) && (debug "f2" (l1 >= l2))
    condition ((o1, i1), (o2, i2)) =
        let l1 = (length i1) * (if o1 == 0 then k else (k - 1))
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)
    printError = do
        putStrLn "-1"
        when (n == 100000 && k == 99999) $ do
            print checkSize
            forM_ (filter (not . condition) con2) $ \ a@((o1, i1), (o2, i2)) -> do
                print "--"
                print o1
                print $ length i1
                print o2
                print $ length i2
                print $ condition2 a

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = unsafePerformIO (putStrLn (s ++ ": " ++ show x)) `seq` x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else printError
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ map condition con2
    condition2 ((o1, i1), (o2, i2)) =
        let l1 = debug "l1" $ (toInteger $ length i1) * (toInteger $ if o1 == 0 then k else (k - 1))
            l2 = debug "l2" $ toInteger $ length i2
        in (debug "f1" (o1 + 1 == o2)) && (debug "f2" (l1 >= l2))
    condition ((o1, i1), (o2, i2)) =
        let l1 = (length i1) * (if o1 == 0 then k else (k - 1))
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)
    printError = do
        putStrLn "-1"
        when (n == 100000 && k == 99999) $ do
            print checkSize
            forM_ (filter (not . condition) con2) $ \ a@((o1, i1), (o2, i2)) -> do
                print "--"
                print o1
                print $ length i1
                print o2
                print $ length i2
                print $ condition2 a

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = trace (s ++ ": " ++ show x) x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else putStrLn "-1"
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ for con2 $ \((o1, i1), (o2, i2)) ->
        let l1 = length i1 * if o1 == 0 then k else k - 1
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = trace (s ++ ": " ++ show x) x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else printError
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ map condition con2
    condition ((o1, i1), (o2, i2)) =
        let l1 = (length i1) * (if o1 == 0 then k else (k - 1))
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)
    printError = do
        putStrLn "-1"
        when (n == 100000 && k == 99999) $ do
            print checkSize
            forM_ (filter (not . condition) con2) $ \ a@((o1, i1), (o2, i2)) -> do
                print "--"
                print o1
                print $ length i1
                print o2
                print $ length i2
                print $ condition a

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = trace (s ++ ": " ++ show x) x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ take n $ zip d [1..]

solve n k d = if hasSolution then printSolution else putStrLn "-1"
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ for con2 $ \((o1, i1), (o2, i2)) ->
        let l1 = length i1 * if o1 == 0 then k else k - 1
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = trace (s ++ ": " ++ show x) x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else printError
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ map condition con2
    condition ((o1, i1), (o2, i2)) =
        let l1 = length i1 * if o1 == 0 then k else k - 1
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)
    printError = do
        putStrLn "-1"
        when (n == 100000 && k == 99999) $ do
            print checkSize
            print $ filter (not . condition) con2

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = trace (s ++ ": " ++ show x) x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else printError
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ map condition con2
    condition ((o1, i1), (o2, i2)) =
        let l1 = length i1 * if o1 == 0 then k else k - 1
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)
    printError = do
        putStrLn "-1"
        when (n == 100000 && k == 99999) $ do
            print checkSize
            forM_ (filter (not . condition) con2) $ \ ((o1, i1), (o2, i2)) -> do
                print "--"
                print o1
                print $ length i1
                print o2
                print $ length i2

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = trace (s ++ ": " ++ show x) x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else printError
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ map condition con2
    condition ((o1, i1), (o2, i2)) =
        let l1 = length i1 * if o1 == 0 then k else k - 1
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)
    printError = do
        putStrLn "-1"
        when (n == 100000 && k == 99999) $ do
            print checkSize
            print $ filter condition con2

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = trace (s ++ ": " ++ show x) x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else putStrLn "-1"
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ for con2 $ \((o1, i1), (o2, i2)) ->
        let l1 = length i1 * if o1 == 0 then k else k - 1
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = trace (s ++ ": " ++ show x) x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else printError
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ for con2 $ \((o1, i1), (o2, i2)) ->
        let l1 = length i1 * if o1 == 0 then k else k - 1
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)
    printError = do
        putStrLn "-1"
        when (n == 100000 && k == 99999) $ do
            print checkSize
            print $ head condense

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = trace (s ++ ": " ++ show x) x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else printError
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ map condition con2
    condition2 ((o1, i1), (o2, i2)) =
        let l1 = debug "l1" $ (length i1) * (if o1 == 0 then k else (k - 1))
            l2 = debug "l2" $ length i2
        in (debug "f1" (o1 + 1 == o2)) && (debug "f2" (l1 >= l2))
    condition ((o1, i1), (o2, i2)) =
        let l1 = (length i1) * (if o1 == 0 then k else (k - 1))
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)
    printError = do
        putStrLn "-1"
        when (n == 100000 && k == 99999) $ do
            print checkSize
            forM_ (filter (not . condition) con2) $ \ a@((o1, i1), (o2, i2)) -> do
                print "--"
                print o1
                print $ length i1
                print o2
                print $ length i2
                print $ condition2 a

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = trace (s ++ ": " ++ show x) x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else putStrLn "-1"
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ for con2 $ \((o1, i1), (o2, i2)) ->
        let l1 = length i1 * if o1 == 0 then k else k - 1
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        forM_ (reverse con2) $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = unsafePerformIO (putStrLn (s ++ ": " ++ show x)) `seq` x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int32]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else putStrLn "-1"
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ map condition con2
    condition ((o1, i1), (o2, i2)) =
        let l1 = (fromIntegral $ length i1) * if o1 == 0 then k else k - 1
            l2 = fromIntegral $ length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = trace (s ++ ": " ++ show x) x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else printError
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ map condition con2
    condition ((o1, i1), (o2, i2)) =
        let l1 = length i1 * if o1 == 0 then k else (k - 1)
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)
    printError = do
        putStrLn "-1"
        when (n == 100000 && k == 99999) $ do
            print checkSize
            forM_ (filter (not . condition) con2) $ \ ((o1, i1), (o2, i2)) -> do
                print "--"
                print o1
                print $ length i1
                print o2
                print $ length i2

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.List
import Debug.Trace
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO

foreign import ccall "stdio.h printf"
    c_printf :: CString -> Int -> Int -> IO CInt

format = unsafePerformIO $ newCString "%d %d\n"
printf = c_printf format

debug s x = trace (s ++ ": " ++ show x) x
for = flip map

main = do
    n:k:d <- map read <$> words <$> getContents :: IO [Int]
    solve n k $ sort $ zip d [1..]

solve n k d = if hasSolution then printSolution else printError
  where
    pack ((order, inds) : tail) (order', ind)
        | order == order' = (order, ind : inds) : tail
        | otherwise       = (order', [ind]) : (order, inds) : tail
    condense    = reverse $ foldl' pack [(0, [])] d
    con2        = zip condense $ tail condense
    hasSolution = (length $ snd $ head condense) == 1 && checkSize
    checkSize   = and $ for con2 $ \((o1, i1), (o2, i2)) ->
        let l1 = length i1 * if o1 == 0 then k else k - 1
            l2 = length i2
        in (o1 + 1 == o2) && (l1 >= l2)
    printSolution = do
        print (n - 1)
        hFlush stdout
        forM_ con2 $ \((o1, i1), (o2, i2)) ->
            forM_ (zip (cycle i1) i2) (uncurry printf)
    printError = do
        putStrLn "-1"
        print checkSize
        print $ head condense

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections #-}

import Control.Applicative
import qualified Data.ByteString.Char8 as B
import Data.List

readInt :: B.ByteString -> Int
readInt bs = case B.readInt bs of Just (n,_) -> n

main :: IO ()
main = do
  [n,k] <- map read.words <$> getLine
  xs <- map readInt.B.words <$> B.getLine
  putStr . solve n k . sort $ zip xs [1..n]

solve :: Int -> Int -> [(Int,Int)] -> String
solve n k ((0,root):xis) = go 1 (shows(n-1).('\n':)) [root] xis
   where
     go _ res _ [] = res ""
     go _ _ [] _ = "-1"
     go !depth !res parents xis
       | fst(head xis) < depth || length parents * k < length yis = "-1"
       | otherwise = go (depth+1) (res.res') (map snd yis) zis
      where
        (yis,zis) = span ((depth==).fst) xis
        yiss = slices k $ map snd yis
        p & c = shows p.(' ':).shows c.('\n':)
        res' = foldr(.) id $zipWith (\p cs->foldr((.).(p&))id cs) parents yiss
solve _ _ _ = "-1"

slices :: Int -> [a] -> [[a]]
slices n xs = map(take n).takeWhile(not.null) $ iterate(drop n)xs
{-# INLINE slices #-}

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections #-}

import Control.Applicative
import qualified Data.ByteString.Char8 as B
import Data.List

readInt :: B.ByteString -> Int
readInt bs = case B.readInt bs of Just (n,_) -> n

main :: IO ()
main = do
  [n,k] <- map read.words <$> getLine
  xs <- map readInt.B.words <$> B.getLine
  putStr . solve n k . sort $ zip xs [1..n]

solve :: Int -> Int -> [(Int,Int)] -> String
solve n k ((0,root):xis) = go 1 (shows(n-1).('\n':)) [root] xis
   where
     go _ res _ [] = res ""
     go _ _ [] _ = "-1"
     go !depth !res parents xis
       | fst(head xis) < depth || length parents * k' < length yis = "-1"
       | otherwise = go (depth+1) (res.res') (map snd yis) zis
      where
        k' = if depth == 1 then k else k-1
        (yis,zis) = span ((depth==).fst) xis
        yiss = slices k' $ map snd yis
        p & c = shows p.(' ':).shows c.('\n':)
        res' = foldr(.) id $zipWith (\p cs->foldr((.).(p&))id cs) parents yiss
solve _ _ _ = "-1"

slices :: Int -> [a] -> [[a]]
slices n xs = map(take n).takeWhile(not.null) $ iterate(drop n)xs
{-# INLINE slices #-}

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections #-}

import Control.Applicative
import qualified Data.ByteString.Char8 as B
import Data.List

readInt :: B.ByteString -> Int
readInt bs = case B.readInt bs of Just (n,_) -> n

main :: IO ()
main = do
  [n,k] <- map read.words <$> getLine
  xs <- map readInt.B.words <$> B.getLine
  putStr . solve n k . sort $ zip xs [1..n]

solve :: Int -> Int -> [(Int,Int)] -> String
solve n k ((0,root):xis) = go 1 (shows(n-1).('\n':)) [root] xis
   where
     go _ res _ [] = res ""
     go !depth !res parents xis
       | null yis || length parents * k < length yis = "-1"
       | otherwise = go (depth+1) (res.res') (map snd yis) zis
      where
        (yis,zis) = span ((depth==).fst) xis
        yiss = slices k $ map snd yis
        res' = foldr(.) id $zipWith (\p cs->foldr(.)id[shows p.(' ':).shows c.('\n':)|c<-cs]) parents yiss
solve _ _ _ = "-1"

slices :: Int -> [a] -> [[a]]
slices n xs = map(take n).takeWhile(not.null) $ iterate(drop n)xs
{-# INLINE slices #-}

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections #-}

import Control.Applicative
import qualified Data.ByteString.Char8 as B
import Data.List

readInt :: B.ByteString -> Int
readInt bs = case B.readInt bs of Just (n,_) -> n

main :: IO ()
main = do
  [n,k] <- map read.words <$> getLine
  xs <- map readInt.B.words <$> B.getLine
  putStr . solve n k . sort $ zip xs [1..n]

solve :: Int -> Int -> [(Int,Int)] -> String
solve n k ((0,root):xis) = go 1 (shows(n-1).('\n':)) [root] xis
   where
     go _ res _ [] = res ""
     go !depth !res parents xis
       | fst(head xis) < depth || length parents * k < length yis = "-1"
       | otherwise = go (depth+1) (res.res') (map snd yis) zis
      where
        (yis,zis) = span ((depth==).fst) xis
        yiss = slices k $ map snd yis
        res' = foldr(.) id $zipWith (\p cs->foldr(.)id[shows p.(' ':).shows c.('\n':)|c<-cs]) parents yiss
solve _ _ _ = "-1"

slices :: Int -> [a] -> [[a]]
slices n xs = map(take n).takeWhile(not.null) $ iterate(drop n)xs
{-# INLINE slices #-}


main = do
  n <- getLine
  a <- getLine
  if (solve n $ words a) then putStrLn "YES"
    else putStrLn "NO"

solve _n _a = judge [0, 0, 0] _a where
  judge _ [] = True
  judge [c25, c50, c100] (a:as)
    | a == "100" =
        if c50 > 0 && c25 > 0 then judge [c25-1, c50-1, c100+1] as
          else if c25 > 2 then judge [c25-3, c50, c100+1] as
            else False
    | a == "50" =
        if c25 > 0 then judge [c25-1, c50+1, c100] as
          else False
    | otherwise = judge [c25+1, c50, c100] as

main = putStrLn . solve 0 0 0 . map read . tail . words =<< getContents
solve f h q (25:bs) = solve f h (q+1) bs
solve f h 0 (50:bs) = "NO"
solve f h q (50:bs) = solve f (h+1) (q-1) bs
solve f 0 q (100:bs) | q >= 3 = solve (f+1) 0 (q-3) bs
                     | otherwise = "NO"
solve f h q (100:bs) | h >= 1 && q >= 1 = solve (f+1) (h-1) (q-1) bs
                     | otherwise = "NO"
solve _ _ _ [] = "YES"

import Control.Applicative
import Control.Monad

main = interact $ booking . tail . words

booking = maybe "NO" (const "YES") . foldM_ change (0, 0)

change (x, y) b = case b of
	"25" -> Just (x + 1, y)
	"50" -> guard (x > 0) >> Just (x - 1, y + 1)
	"100" -> (guard (x > 0 && y > 0) >> Just (x - 1, y - 1))
		<|>  (guard (x > 2) >> Just (x - 3, y))

import Control.Applicative ((<|>))
import Control.Monad (guard, foldM)

data Bill = R25 | R50 | R100
data Result = YES | NO deriving (Show)

main = interact $ show . booking . map readBill . tail . words

booking :: [Bill] -> Result
booking = maybe NO (const YES) . foldM change (0, 0)

change :: (Int, Int) -> Bill -> Maybe (Int, Int)
change (n25, n50) bill = case bill of
	R25 -> return (n25 + 1, n50)
	R50 -> guard (n25 > 0) >> return (n25 - 1, n50 + 1)
	R100 -> (guard (n50 > 0 && n25 > 0) >> return (n25 - 1, n50 - 1))
		<|> (guard (n25 > 2) >> return (n25 - 3, n50))

readBill :: String -> Bill
readBill s = case s of
	"25" -> R25
	"50" -> R50
	"100" -> R100

import Control.Monad (foldM)

data Bill = R25 | R50 | R100
data Result = YES | NO deriving (Show)

main = interact $ show . booking . map readBill . tail . words

booking :: [Bill] -> Result
booking = maybe NO (const YES) . foldM (flip change) (0, 0)

change :: Bill -> (Int, Int) -> Maybe (Int, Int)
change R25 (n25, n50) = Just (n25 + 1, n50)
change R50 (n25, n50)
	| n25 > 0 = Just (n25 - 1, n50 + 1)
	| otherwise = Nothing
change R100 (n25, n50)
	| n50 > 0 && n25 > 0 = Just (n25 - 1, n50 - 1)
	| n25 > 2 = Just (n25 - 3, n50)
	| otherwise = Nothing

readBill :: String -> Bill
readBill s = case s of
	"25" -> R25
	"50" -> R50
	"100" -> R100

data Bill = R25 | R50 | R100
data Result = YES | NO deriving (Show)

main = interact $ show . booking . map readBill . tail . words

booking :: [Bill] -> Result
booking = go (0, 0) where
	go _ [] = YES
	go n (x:xs) = case change x n of
		Just n' -> go n' xs
		Nothing -> NO

readBill :: String -> Bill
readBill s = case s of
	"25" -> R25
	"50" -> R50
	"100" -> R100

change :: Bill -> (Int, Int) -> Maybe (Int, Int)
change R25 (n25, n50) = Just (n25 + 1, n50)
change R50 (n25, n50) = if n25 > 0
	then Just (n25 - 1, n50 + 1)
	else Nothing
change R100 (n25, n50) = if n50 > 0
	then if n25 > 0
		then Just (n25 - 1, n50 - 1)
		else Nothing
	else if n25 > 2
		then Just (n25 - 3, n50)
		else Nothing

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

main = interact $ booking . tail . words

booking = maybe "NO" (const "YES") . foldM_ change (0, 0)

change (!x, !y) b = case b of
	"25" -> Just (x + 1, y)
	"50" -> guard (x > 0) >> Just (x - 1, y + 1)
	"100" -> (guard (x > 0 && y > 0) >> Just (x - 1, y - 1))
		<|>  (guard (x > 2) >> Just (x - 3, y))

import Control.Applicative
import Control.Monad

main = interact $ booking . tail . words

booking = maybe "NO" (const "YES") . foldM change (0, 0)

change (x, y) b = case b of
	"25" -> Just (x + 1, y)
	"50" -> guard (x > 0) >> Just (x - 1, y + 1)
	"100" -> (guard (x > 0 && y > 0) >> Just (x - 1, y - 1))
		<|>  (guard (x > 2) >> Just (x - 3, y))

import Control.Applicative
import Control.Monad

main = interact $ booking . tail . words

booking = maybe "NO" (const "YES") . foldM change (0, 0)

change (x, y) b = case b of
	"25" -> Just $! (x + 1, y)
	"50" -> guard (x > 0) >> (Just $! (x - 1, y + 1))
	"100" -> (guard (x > 0 && y > 0) >> (Just $! (x - 1, y - 1)))
		<|>  (guard (x > 2) >> (Just $! (x - 3, y)))

import Control.Applicative ((<|>))
import Control.Monad (guard, foldM)

main = interact $ booking . tail . words

booking = maybe "NO" (const "YES") . foldM change (0, 0)

change (n25, n50) bill = case bill of
	"25" -> return (n25 + 1, n50)
	"50" -> guard (n25 > 0) >> return (n25 - 1, n50 + 1)
	"100" -> (guard (n50 > 0 && n25 > 0) >> return (n25 - 1, n50 - 1))
		<|>  (guard (n25 > 2) >> return (n25 - 3, n50))

import Control.Applicative
import Control.Monad
import System.IO
import Data.Maybe
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C

-- |Model the change state. First entry is number of 25 notes, second number
-- of 50 notes
type Change = (Int,Int)

-- * Solver
-- |Solve a test case
solve :: [Int] -> String
solve xs = case solve' xs of
    (Just _) -> "YES"
    Nothing  -> "NO"
    where solve' xs = foldl (>>=) (return (0,0)) $ map process xs

-- |Process one consumer
process :: Int           -- ^ Note of consumer
        -> Change        -- ^ Old 'Change' state
        -> Maybe Change  -- ^ New 'Change' state or 'Nothing' if transaction is
                         -- impossible
process 25  (a,b) = return (a+1,b)
process 50  (a,b) = guard (a >= 1) >> return (a-1,b+1)
process 100 (a,b)
    | b > 0     = guard (a >= 1) >> return (a-1,b-1)
    | otherwise = guard (a >= 3) >> return (a-3,b)

-- * Input/Output
-- |Ignore the first line and parse the test case
main :: IO ()
main = do
    B.getLine
    xs <- getIntList
    putStrLn $ solve xs

-- |Read an Int list from the standard input device
getIntList :: IO [Int]
getIntList = readIntList `fmap` B.getLine

-- * Converting from ByteString
-- |Cast ByteString to Int
readInt :: C.ByteString -> Int
readInt = fst . fromJust . C.readInt

-- |Cast ByteString to Int list
readIntList :: C.ByteString -> [Int]
readIntList = map readInt . C.words

import Control.Applicative
import Control.Monad
import System.IO
import Data.Maybe
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C

type Change = (Int,Int)

solve :: [Int] -> String
solve xs = case solve' xs of
    (Just _) -> "YES"
    Nothing  -> "NO"
    where solve' xs = foldM process (0,0) xs

process :: Change -> Int -> Maybe Change
process (a,b) 25 = return $! (a+1,b)
process (a,b) 50 = guard (a >= 1) >> (return $! (a-1,b+1))
process (a,b) 100
    | b > 0     = guard (a >= 1) >> (return $! (a-1,b-1))
    | otherwise = guard (a >= 3) >> (return $! (a-3,b))

main :: IO ()
main = do
    B.getLine
    xs <- getIntList
    putStrLn $ solve xs

getIntList :: IO [Int]
getIntList = readIntList `fmap` B.getLine

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

readIntList :: C.ByteString -> [Int]
readIntList = map readInt . C.words

module Main where
import System.IO
import Data.Maybe
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C

solve :: [Int] -> String
solve xs = if solve' (0,0) xs then "YES" else "NO"

solve' :: (Int,Int) -> [Int] -> Bool
solve' (a,b) _ | a < 0 || b < 0 = False
solve' _ [] = True
solve' (a,b) (25:xs) = solve' (a+1,b) xs
solve' (a,b) (50:xs) = solve' (a-1,b+1) xs
solve' (a,b) (100:xs) = if b > 0 then solve' (a-1,b-1) xs else solve' (a-3,b) xs

main :: IO ()
main = do
	B.getLine
	ls <- B.getLine
	putStrLn . solve . map readInt . C.words $ ls

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

#!/usr/bin/env runghc
import Data.List
main = do
  c <- getContents
  putStr . unlines . solve . lines $ c

solve::[String]->[String]
solve [] = []
solve (c1:c2:cs) = (f (0,0) . map read . words $ c2): solve cs
  where
    f rs [] = "YES"
    f (r1,r2) (n:ns) =
      if n==25 then f (r1+1,r2) ns
      else if n==50 && r1>0 then f (r1-1,r2+1) ns
      else if n==100 && r1>0 && r2>0 then f (r1-1,r2-1) ns
      else if n==100 && r1>2 then f (r1-3,r2) ns
      else "NO"

solve :: [Integer] -> Integer -> Integer -> Bool
solve [] _ _ = True
solve (25:xs) q h = solve xs (q + 1) h
solve (50:xs) 0 _ = False
solve (50:xs) q h = solve xs (q - 1) (h + 1)
solve (100:xs) q h
    | q > 0 && h > 0 = solve xs (q - 1) (h - 1)
    | q > 2 = solve xs (q - 3) h
    | otherwise = False

main = do
    n <- getLine
    a <- getLine
    if solve (map read $ words a) 0 0 then
        putStrLn "YES"
    else
        putStrLn "NO"

work m n xs = if m < 0 || n < 0
              then "NO"
              else
                if null xs
                  then "YES"
                  else
                    case (head xs) of
                      100 -> if n > 0
                             then work (m-1) (n-1) (tail xs)
                             else work (m-3) n (tail xs)
                      50  -> work (m-1) (n+1) (tail xs)
                      25  -> work (m+1) n (tail xs)

main = do s <- getLine
          s <- getLine
          let xs = map (\x -> read x :: Int) (words s)
          putStrLn (work 0 0 xs)

module Main where

import Control.Applicative

data Result = YES | NO deriving (Eq,Show)

main = do
    getLine
    l <- map read <$>words <$> getLine
    print $ solve (0, 0) l

solve :: (Int, Int) -> [Int] -> Result
solve _ [] = YES
solve (a,b) (25:xs) = solve (a+1,b) xs
solve (a,b) (50:xs) | a > 0 = solve (a-1,b+1) xs
                    | otherwise = NO
solve (a,b) (100:xs)| b > 0 && a > 0 = solve (a-1, b-1) xs
                    | a > 2 = solve (a-3,b) xs
                    | otherwise = NO

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

process x y z [] = "YES"
process x y z (a:as) | a==25 = process (x+1) y z as
	             | a==50 && x>0 = process (x-1) (y+1) z as
		     | a==50 = "NO"
		     | a==100 && y>0 && x>0 = process (x-1) (y-1) (z+1) as
                     | a==100 && x>=3 = process (x-3) y (z+1) as
                     | otherwise = "NO"

main=do
	getLine
	s<-map (fst.fromJust.C.readInt). C.words<$> C.getLine::IO [Int]
	putStrLn $ process 0 0 0 s

main = do
    (_:a) <- fmap (map read . words) getContents :: IO [Int]
    putStrLn $ f 0 0 a
f _ _ [] = "YES"
f x y (a:as)
    | a == 25 = f (x + 1) y as
    | a == 50 = if x > 0 then f (x - 1) (y + 1) as else "NO"
    | otherwise = if y > 0 && x > 0 then f (x - 1) (y - 1) as else if x > 2 then f (x - 3) y as else "NO"

import Data.List

cal ls = let bills = map (+0) $ map read $ words $ ls !! 1
             neededChange = map ( + (-25)) bills
	 in sell bills 0 0

sell bills c25 c50
	| c25<0 || c50 <0 = "NO"
	| bills == [] = "YES"
	| (head bills) == 25 = sell (tail bills) (c25+1) c50
	| (head bills) == 50 = sell (tail bills) (c25-1) (c50+1)
	| c50 >0 = sell (tail bills) (c25 -1) (c50-1)
	| otherwise = sell (tail bills) (c25 -3) c50

main = interact ( cal . lines)

module Main where

import Data.Maybe
import Data.List (foldl')

type Change = (Int,Int)

rush :: [Int] -> Bool
rush = isJust . foldl' f (Just (0,0))
  where f :: Maybe Change -> Int -> Maybe Change
        f (Just (a,b)) 25 = Just (a+1,b)
        f (Just (a,b)) 50 = if a > 0 then Just (a - 1, b + 1)
                                else Nothing
        f (Just (a,b)) 100
          | b >= 1 && a >= 1 = Just (a - 1, b - 1)
          | a >= 3 = Just (a - 3, b)
          | otherwise = Nothing
        f _ _ = Nothing

main :: IO ()
main = do
  _:l <- fmap (map read . words) getContents
  putStrLn $ if rush l then "YES" else "NO"

import Data.List
import Data.Maybe
import Control.Applicative
import Debug.Trace

debug x = trace (show x) x
(|>) x f = f x; infixl 1 |>
(||>) x f = x >>= (return.f); infixl 1 ||>
ref = (!!)

go :: [Int] -> (Int,Int) -> Bool
go [] _ = True
go (25:xs) (a,b) = go xs (a+1,b)
go (50:xs) (a,b)
  | a < 1   = False
  | True    = go xs (a-1,b+1)
go (100:xs) (a,b)
  | a>0 && b>0   = go xs (a-1,b-1)
  | a >= 3  = go xs (a-3,b)
  | True    = False

main = do
  ls <- getContents ||> lines
  n  <- head ls |> readIO :: IO Int
  xs <- (ref ls 1) |> words |> map read |> return  :: IO [Int]
  putStrLn (if (go xs (0,0)) then "YES" else "NO")

-- vim: set ft=haskell:

import Data.List
import Data.Char
import Data.Maybe
import Control.Applicative
import Debug.Trace
import qualified Data.ByteString.Char8 as B

toDigit n = chr (48 + n)

debug x = trace (show x) x
(|>) x f = f x; infixl 1 |>
(||>) mx f = mx >>= (return . f); infixl 1 ||>
ref = (!!)

go :: [Int] -> (Int,Int) -> Bool
go [] _ = True
go (25:xs) (a,b) = go xs (a+1,b)
go (50:xs) (a,b)
  | a < 1   = False
  | True    = go xs (a-1,b+1)
go (100:xs) (a,b)
  | a>0 && b>0   = go xs (a-1,b-1)
  | a >= 3  = go xs (a-3,b)
  | True    = False

main = do
  ls <- B.getContents ||> B.lines
  n  <- head ls |> B.readInt |> fromJust |> fst |> return :: IO Int
  xs <- (ref ls 1) |> B.words |> map (fst . fromJust . B.readInt) |> return  :: IO [Int]
  putStrLn (if (go xs (0,0)) then "YES" else "NO")

-- vim: set ft=haskell:

import Data.List
import Data.Maybe
import Control.Applicative
import Debug.Trace
debug x = trace (show x) x
(|>) x f = f x; infixl 1 |>
(||>) x f = x >>= (return.f); infixl 1 ||>
ref = (!!)

go [] _ = True
go ("25":xs) (a,b) = go xs (a+1,b)
go ("50":xs) (a,b)
  | a < 1   = False
  | True    = go xs (a-1,b+1)
go ("100":xs) (a,b)
  | a>0 && b>0   = go xs (a-1,b-1)
  | a >= 3  = go xs (a-3,b)
  | True    = False

main = do
  ls <- getContents ||> lines
  n  <- head ls |> readIO :: IO Int
  xs <- (ref ls 1) |> words |> return  :: IO [String]
  putStrLn (if (go xs (0,0)) then "YES" else "NO")

-- vim: set ft=haskell:

main = do
  n <- getLine
  a <- getLine
  if (solve n $ words a) then putStrLn "YES"
    else putStrLn "NO"

solve _n _a = judge [0, 0, 0] _a where
  judge _ [] = True
  judge (c25:c50:c100:[]) (a:as)
    | a == "100" =
        if c50 > 0 && c25 > 0 then judge (c25-1:c50-1:c100+1:[]) as
          else if c25 > 2 then judge (c25-3:c50:c100+1:[]) as
            else False
    | a == "50" =
        if c25 > 0 then judge (c25-1:c50+1:c100:[]) as
          else False
    | otherwise = judge (c25+1:c50:c100:[]) as

main = do
  n <- getLine
  a <- getLine
  if (solve n $ words a) then putStrLn "YES"
    else putStrLn "NO"

solve _n _a = judge 0 0 0 _a where
  judge _ _ _ [] = True
  judge c25 c50 c100 (a:as) =
    case a of
      "100" ->
        if c50 > 0 && c25 > 0 then (judge (c25-1) (c50-1) (c100+1) as)
          else if c25 > 2 then (judge (c25-3) c50 (c100+1) as)
            else False
      "50" ->
        if c25 > 0 then (judge (c25-1) (c50+1) c100 as)
          else False
      "25" -> (judge (c25+1) c50 c100 as)

main = do
  n <- getLine
  a <- getLine
  if (solve n $ words a) then putStrLn "YES"
    else putStrLn "NO"

solve _n _a = judge 0 0 0 _a where
  judge _ _ _ [] = True
  judge c25 c50 c100 (a:as)
    | a == "100" =
        if c50 > 0 && c25 > 0 then judge (c25-1) (c50-1) (c100+1) as
          else if c25 > 2 then judge (c25-3) c50 (c100+1) as
            else False
    | a == "50" =
        if c25 > 0 then judge (c25-1) (c50+1) c100 as
          else False
    | otherwise = judge (c25+1) c50 c100 as

import Data.List (foldl')

main = do
  n <- getLine
  a <- getLine
  let rv = (solve n $ words a)
  if snd rv == True then putStrLn "YES"
    else putStrLn "NO"

solve n xs = foldl' go ((0, 0, 0), True) xs where
  go ((_, _, _), b) "" = ((0, 0, 0), True && b)
  go ((c25, c50, c100), b) x
    | x == "100" =
        if c50 > 0 && c25 > 0 then ((c25-1, c50-1, c100+1), b)
          else if c25 > 2 then ((c25-3, c50, c100+1), b)
            else ((0, 0, 0), False)
    | x == "50" =
        if c25 > 0 then ((c25-1, c50+1, c100), b)
            else ((0, 0, 0), False)
    | otherwise = ((c25+1, c50, c100), b)

import Control.Applicative
import Control.Monad
import Control.Arrow
import Data.List
import Data.Char
import Text.Printf

main = do
	getLine
	as <- map read . words <$> getLine
	let
		res = solve 0 0 0 as
	putStrLn res

solve _ _ _ [] = "YES"
solve c25 c50 c100 (a:as)
	| a == 25 = solve ( c25 + 1 ) c50 c100 as
	| a == 50 = if c25 == 0
		then "NO"
		else solve ( c25 - 1 ) ( c50 + 1 ) c100 as
	| a == 100 && 1 <= c25 && 1 <= c50 = solve ( c25 - 1 ) ( c50 -1 ) ( c100 + 1 ) as
	| a == 100 && 3 <= c25 = solve ( c25 - 3 ) c50 ( c100 + 1 ) as
	| otherwise = "NO"

import Control.Applicative
get :: IO [Int]
get = fmap (map read.words) getContents

solve :: Int -> Int -> Int -> [Int] -> String
solve a b c []
  | a < 0 || b < 0 || c < 0 = "NO"
  | otherwise = "YES"
solve a b c (x:xs) -- 25, 50, 100 demonination change
  | a < 0 || b < 0 || c < 0 = "NO"
  | x == 25 = solve (a+1) b c xs
  | x == 50 = solve (a-1) (b+1) c xs
  | x == 100 = if b > 0
               then solve (a-1) (b-1) (c+1) xs
               else solve (a-3) b (c+1) xs

main :: IO ()
main=do
  (_:line) <- get
  putStrLn (solve 0 0 0 line)

import Control.Applicative
main :: IO ()
main = do
    getLine
    xs <- map read <$> words <$> getLine
    if solve 0 0 0 xs
        then putStrLn "YES"
        else putStrLn "NO"

solve :: Int -> Int -> Int -> [Int] -> Bool
solve _ _ _ []     = True
solve d100 d50 d25 (x:xs)
    | x == 25 = solve d100 d50 (d25 + 1) xs
    | x == 50 && d25 >= 1 = solve d100 (d50 + 1) (d25 - 1) xs
    | x == 100 && d50 >= 1 && d25 >= 1 = solve (d100 + 1) (d50 - 1) (d25 - 1) xs
    | x == 100 && d25 >= 3 = solve (d100 + 1) d50 (d25 - 3) xs
    | otherwise = False

check :: [Int] -> (Int, Int) -> String
check [] _                       = "YES"
check (x:xs) (d, p)
  | x == 25                      = check xs (d+1, p)
  | x == 50   && (d > 0)          = check xs (d-1, p+1)
  | x == 100  && (d > 0 && p > 0) = check xs (d-1, p-1)
  | x == 100  && (d > 2)          = check xs (d-3, p)
  | otherwise                    = "NO"

main = getLine >> getLine >>= return . (flip check) (0,0) . (map read) . words >>= putStrLn

{-# OPTIONS_GHC -O2 #-}

import qualified Data.ByteString.Char8 as B

main :: IO ()
main = do
  getLine
  putStrLn . solve (0, 0) . map (maybe 0 fst . B.readInt) . B.words =<< B.getContents

solve :: (Int, Int) -> [Int] -> String
solve (q, h) _ | q <0 || h < 0 = "NO"
solve (q, h) [] = "YES"
solve (q, h) (25 : bs) = solve (q + 1, h) bs
solve (q, h) (50 : bs) = solve (q - 1, h + 1) bs
solve (q, 0) (100 : bs) = solve (q - 3, 0) bs
solve (q, h) (100 : bs) = solve (q - 1, h - 1) bs

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

import Control.Applicative
import Control.Monad hiding ((<$!>))
import Control.Monad.ST.Safe
import Control.Monad.State hiding ((<$!>))
-- import Data.Array
import Data.Array.IArray
import Data.Array.IO.Safe
import Data.Array.MArray.Safe
import Data.Array.ST.Safe
import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Builder as BB
import Data.Char
import qualified Data.Foldable as F
import Data.Function
import Data.Graph
import Data.Int
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Ord
import Data.Ratio
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
-- import Data.Tree
import Data.Tuple
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
-- import Debug.Trace
import System.IO

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

main = do
  getLine
  xs <- getInts

  let
    r = f (0, 0, 0) xs
      where
        f _ [] = True
        f (a, b, c) (25:xs) = f (a+1, b, c) xs
        f (a, b, c) (50:xs)
          | a >= 1 = f (a-1, b+1, c) xs
          | otherwise = False
        f (a, b, c) (100:xs)
          | b >= 1 && a >= 1 = f (a-1, b-1, c+1) xs
          | a >= 3 = f (a-3, b, c+1) xs
          | otherwise = False

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

import Data.List
import Data.Tree
import Data.Int
import Data.Maybe
import Data.Char
import Data.Functor
import Data.Bits
import Data.Monoid
import Control.Monad
import Control.Monad.ST.Safe
import Control.Arrow
import Data.Array
import Data.Array.ST.Safe
import Data.Array.Unboxed as UA
import Data.STRef
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as C
main=   readsolveprint
readsolveprint::IO()
readsolveprint = getLine >>=  \n-> (solve.concat =<< forM [1.. 1] ( \i -> map (fst.fromJust.C.readInteger).C.words<$>C.getLine))
solve xs =  if slv1 xs (0,0) then putStr "YES" else putStr "NO"
slv1 [] _ = True
slv1 (x:xs) (y25,y50)      | x ==25                    = slv1 xs (y25+1,y50)
                           | x ==50 && y25==0          = False
                           | x ==50 && y25/=0          = slv1 xs (y25-1,y50+1)
                           | x ==100 && y50>0 && y25>0 = slv1 xs (y25-1,y50-1)
                           | x ==100 && y50==0 && y25>2 = slv1 xs (y25-3,y50)
                           | otherwise                 = False

import Control.Monad (liftM)
import Data.Char (ord)
import Prelude hiding (reads)

reads :: IO [Int]
reads  =  liftM (map read . words) getLine
  where
    read ('-' : s)  =  (-1) * read s
    read s  =  read' 0 s
    read' a ""  =  a
    read' a (c:s)  =  read' a' s
      where
        a'  =  10*a + ord c - ord '0'

solve :: [Int] -> Bool
solve as  =  solve' 0 0 as
  where
    solve' _ _ []  =  True
    solve' a b (25:as)  =  solve' (a+1) b as
    solve' a b (50:as)
        | a > 0  =  solve' (a-1) (b+1) as
        | otherwise  =  False
    solve' a b (100:as)
        | a > 0 && b > 0  =  solve' (a-1) (b-1) as
        | a > 2  =  solve' (a-3) b as
        | otherwise  =  False

main :: IO ()
main  =  do
    getLine
    as  <-  reads
    if solve as then
        putStrLn "YES"
    else
        putStrLn "NO"

module Main where
import Control.Applicative
import Control.Monad
import Data.ByteString.Lazy as B
import Data.ByteString.Lazy.Char8 as C
main :: IO ()
main = do
    _ <- getLine
    bills <- (Prelude.map ((\ (Just (i,_)) -> i) . C.readInt) . C.words) <$> B.getContents :: IO [Int]
    let cando (twfs,fifs) 25 = Just (twfs+1,fifs)
        cando (twfs,fifs) 50
          | twfs > 0 = Just (twfs-1,fifs+1)
          | otherwise = Nothing
        cando (twfs,fifs) 100
          | twfs >= 1 && fifs >= 1 = Just (twfs-1,fifs-1)
          | twfs >= 3 = Just (twfs-3,fifs)
          | otherwise = Nothing
    Prelude.putStrLn (case foldM cando (0,0) bills of
      Nothing -> "NO"
      _ -> "YES")

main = do
    getLine
    input <- getLine >>= return.(map read).words
    putStrLn $ solve input 0 0

solve :: [Int] -> Int -> Int -> String
solve [] _ _ = "YES"
solve (25:xs) a b = solve xs (a+1) b
solve (50:xs) a b
    | a==0      = "NO"
    | otherwise = solve xs (a-1) (b+1)
solve (100:xs) a b
    | a>0 && b>0 = solve xs (a-1) (b-1)
    | a>2        = solve xs (a-3) b
    | otherwise  = "NO"

main :: IO ()
main = getContents >>= putStrLn . yesno . solve . map read . words . (!!1) . lines

solve :: [Int] -> Bool
solve = all g . scanl f (0 :: Int, 0 :: Int)
  where f (a, b) 25 = (a + 1, b)
        f (a, b) 50 = (a - 1, b + 1)
        f (a, b) 100 | b > 0 = (a - 1, b - 1)
                     | otherwise = (a - 3, b)
        f ab _ = ab
        g (a, b) = a >= 0 && b >= 0

yesno :: Bool -> String
yesno True = "YES"
yesno _ = "NO"

import Control.Applicative
get :: IO [Int]
get = fmap (map read.words) getContents

solve :: Int -> Int -> Int -> [Int] -> String
solve a b c []
  | a < 0 || b < 0 || c < 0 = "NO"
  | otherwise = "YES"
solve a b c (x:xs) -- 25, 50, 100 demonination change
  | a < 0 || b < 0 || c < 0 = "NO"
  | x == 25 = solve (a+1) b c xs
  | x == 50 = solve (a-1) (b+1) c xs
  | x == 100 = if b > 1
               then solve (a-1) (b-1) (c+1) xs
               else solve (a-3) b (c+1) xs

main :: IO ()
main=do
  (_:line) <- get
  putStrLn (solve 0 0 0 line)

check :: [Int] -> (Int, Int) -> String
check [] _                       = "YES"
check (x:xs) (d, p)
  | x == 25                      = check xs (d+1, p)
  | x == 50                      = check xs (d-1, p+1)
  | x == 100 && (d > 1 && p > 1) = check xs (d-1, p-1)
  | x == 10  && (d > 4)          = check xs (d-3, p)
  | otherwise                    = "NO"

main = getLine >> getLine >>= return . (flip check) (0,0) . (map read) . words >>= putStrLn

check :: [Int] -> (Int, Int) -> String
check [] _                       = "YES"
check (x:xs) (d, p)
  | x == 25                      = check xs (d+1, p)
  | x == 50  && (d > 0)          = check xs (d-1, p+1)
  | x == 100 && (d > 1 && p > 1) = check xs (d-1, p-1)
  | x == 10  && (d > 4)          = check xs (d-3, p)
  | otherwise                    = "NO"

main = getLine >> getLine >>= return . (flip check) (0,0) . (map read) . words >>= putStrLn

check :: [Int] -> (Int, Int) -> String
check [] _                       = "YES"
check (x:xs) (d, p)
  | x == 25                      = check xs (d+1, p)
  | x == 50  && (d > 1)          = check xs (d-1, p+1)
  | x == 100 && (d > 1 && p > 1) = check xs (d-1, p-1)
  | x == 10  && (d > 4)          = check xs (d-3, p)
  | otherwise                    = "NO"

main = getLine >> getLine >>= return . (flip check) (0,0) . (map read) . words >>= putStrLn

module Main where
-- import Control.Monad
-- import Data.List
-- import Data.Array
import Control.Applicative
import Control.Monad
main :: IO ()
main = do
    _ <- getLine
    bills <- (map read . words) <$> getLine :: IO [Int]
    let cando (twfs,fifs,hunnas) 25 = Just (twfs+1,fifs,hunnas)
        cando (twfs,fifs,hunnas) 50
          | twfs == 0 = Nothing
          | otherwise = Just (twfs-1,fifs,hunnas)
        cando (twfs,fifs,hunnas) 100
          | twfs >= 1 && fifs >= 1 = Just (twfs-1,fifs-1,hunnas)
          | twfs >= 3 = Just (twfs-3,fifs,hunnas)
          | otherwise = Nothing
    case foldM cando (0,0,0) bills of
      Nothing -> putStrLn "NO"
      _ -> putStrLn "YES"

main :: IO ()
main = getContents >>= putStrLn . yesno . solve . map read . words . (!!1) . lines

solve :: [Int] -> Bool
solve = all g . scanl f (0 :: Int, 0 :: Int)
  where f (a, b) 25 = (a + 1, b)
        f (a, b) 50 = (a - 1, b + 1)
        f (a, b) 100 | b >= 0 = (a - 1, b - 1)
                     | otherwise = (a - 3, b)
        f ab _ = ab
        g (a, b) = a >= 0 && b >= 0

yesno :: Bool -> String
yesno True = "YES"
yesno _ = "NO"

main :: IO ()
main = getContents >>= putStrLn . yesno . solve . map read . words . (!!1) . lines

solve :: [Int] -> Bool
solve = and . zipWith (>=) [25,50..]

yesno :: Bool -> String
yesno True = "YES"
yesno _ = "NO"

main :: IO ()
main = getContents >>= putStrLn . yesno . solve . map read . words . (!!1) . lines

solve :: [Int] -> Bool
solve = all (>=0) . scanl (\a b -> a + b - 25) 0

yesno :: Bool -> String
yesno True = "YES"
yesno _ = "NO"

import Control.Applicative
import Control.Monad
import System.IO
import Data.Maybe
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C

-- |Model the change state. First entry is number of 25 notes, second number
-- of 50 notes
type Change = (Int,Int)

-- * Solver
-- |Solve a test case
solve :: [Int] -> String
solve xs = case solve' xs of
    (Just _) -> "YES"
    Nothing  -> "NO"
    where solve' xs = foldl (>>=) (return (0,0)) $ map process xs

-- |Process one consumer
process :: Int           -- ^ Note of consumer
        -> Change        -- ^ Old 'Change' state
        -> Maybe Change  -- ^ New 'Change' state or 'Nothing' if transaction is
                         -- impossible
process 25  (a,b) = return (a+1,b)
process 50  (a,b) = guard (a >= 1) >> return (a-1,b+1)
process 100 (a,b)
    | b > 0     = guard (a >= 0) >> return (a-1,b-1)
    | otherwise = guard (a >= 2) >> return (a-3,b)

-- * Input/Output
-- |Ignore the first line and parse the test case
main :: IO ()
main = do
    B.getLine
    xs <- getIntList
    putStrLn $ solve xs

-- |Read an Int list from the standard input device
getIntList :: IO [Int]
getIntList = readIntList `fmap` B.getLine

-- * Converting from ByteString
-- |Cast ByteString to Int
readInt :: C.ByteString -> Int
readInt = fst . fromJust . C.readInt

-- |Cast ByteString to Int list
readIntList :: C.ByteString -> [Int]
readIntList = map readInt . C.words

work m n xs = if m < 0 || n < 0
              then "NO"
              else
                if null xs
                  then "YES"
                  else
                    case (head xs) of
                      100 -> work (m-1) (n-1) (tail xs)
                      50  -> work (m-1) (n+1) (tail xs)
                      25  -> work (m+1) n (tail xs)

main = do s <- getLine
          s <- getLine
          let a = map (\x -> read x :: Int) (words s)
          putStrLn (work 0 0 a)

work m n xs = if m < 0 || n < 0
              then "NO"
              else
                if null xs
                  then "YES"
                  else
                    case (head xs) of
                      100 -> if n > 0
                             then work (m-1) (n-1) (tail xs)
                             else work (m-1) n (tail xs)
                      50  -> work (m-1) (n+1) (tail xs)
                      25  -> work (m+1) n (tail xs)

main = do s <- getLine
          s <- getLine
          let xs = map (\x -> read x :: Int) (words s)
          putStrLn (work 0 0 xs)

module Main where

import Control.Applicative

data Result = YES | NO deriving (Eq,Show)

main = do
    getLine
    l <- map read <$>words <$> getLine
    print $ solve (0, 0) l

solve :: (Int, Int) -> [Int] -> Result
solve _ [] = YES
solve (a,b) (25:xs) = solve (a+1,b) xs
solve (a,b) (50:xs) | a > 0 = solve (a-1,b+1) xs
                    | otherwise = NO
solve (a,b) (100:xs)| b > 0 && a > 0 = solve (a-1, b-1) xs
                    | a > 1 = solve (a-2,b) xs
                    | otherwise = NO

main = do
    (_:a) <- fmap (map read . words) getContents :: IO [Int]
    putStrLn $ f 0 0 a
f _ _ [] = "YES"
f x y (a:as)
    | a == 25 = f (x + 1) y as
    | a == 50 = if x > 0 then f (x - 1) (y - 1) as else "NO"
    | otherwise = if y > 0 && x > 0 then f (x - 1) (y - 1) as else if x > 2 then f (x - 3) y as else "NO"

import Data.List

cal ls = let bills = map (+0) $ map read $ words $ ls !! 1
             neededChange = map ( + (-25)) bills
	 in sell bills 0 0

sell bills c25 c50
	| c25<0 || c50 <0 = "NO"
	| bills == [] = "YES"
	| (head bills) == 25 = sell (tail bills) (c25+1) c50
	| (head bills) == 50 = sell (tail bills) (c25-1) (c50+1)
	| c50 >0 = sell (tail bills) (c25 -1) (c50-1)
	| otherwise = sell (tail bills) (c25 -3) c50

main = interact ( show . cal . lines)

import Data.List
import Data.Maybe
import Control.Applicative
import Debug.Trace

debug x = trace (show x) x
(|>) x f = f x; infixl 1 |>
(||>) x f = x >>= (return.f); infixl 1 ||>
ref = (!!)

go :: [Int] -> (Int,Int,Int) -> Bool
go [] _ = True
go (25:xs) (a,b,c) = go xs (a+1, b, c)
go (50:xs) (a,b,c)
  | a < 1 = False
  | True  = go xs (a-1, b+1, c)
go (100:xs) (a,b,c)
  | b > 0    = go xs (a, b-1, c+1)
  | a >= 3   = go xs (a-3, b, c+1)
  | True     = False

main = do
  ls <- getContents ||> lines
  n  <- head ls |> readIO :: IO Int
  xs <- (ref ls 1) |> words |> map read |> return  :: IO [Int]
  putStrLn (if (go xs (0,0,0)) then "YES" else "NO")

-- vim: set ft=haskell: