Consider a rooted tree. A rooted tree has one special vertex called the root. All edges are directed from the root. Vertex u is called a child of vertex v and vertex v is called a parent of vertex u if there exists a directed edge from v to u. A vertex is called a leaf if it doesn't have children and has a parent.Let's call a rooted tree a spruce if its every non-leaf vertex has at least 3 leaf children. You are given a rooted tree, check whether it's a spruce.The definition of a rooted tree can be found here.

The first line contains one integer n — the number of vertices in the tree (3 ≤ n ≤ 1 000). Each of the next n - 1 lines contains one integer pi (1 ≤ i ≤ n - 1) — the index of the parent of the i + 1-th vertex (1 ≤ pi ≤ i). Vertex 1 is the root. It's guaranteed that the root has at least 2 children.

Print "Yes" if the tree is a spruce and "No" otherwise.

NoteThe first example:The second example:It is not a spruce, because the non-leaf vertex 1 has only 2 leaf children.The third example:

main = getContents >>= putStrLn . solve . map read . lines

solve (n:p') = if minimum lnum >= 3 then "Yes" else "No"
    where p = map pred p'
          leaf = filter (not . (`elem` p)) [1 .. n - 1]
          lp = [ p !! (x - 1) | x <- leaf]
          lnum = [ length $ filter (==x) lp | x <- p ]

import Data.List

main = getContents >>= putStrLn . solve . map read . lines

solve (n:p') = if minimum lnum >= 3 then "Yes" else "No"
    where p = map pred p'
          leaf = filter (not . (`elem` p)) [1 .. n - 1]
          lp = [ p !! (x - 1) | x <- leaf]
          lnum = [ length $ elemIndices x lp | x <- p ]

import Control.Applicative
import Data.Maybe
import Data.List
import qualified Data.Map as Map

updateIsLeaf :: Map.Map Int Bool -> [Int] -> Map.Map Int Bool
updateIsLeaf a [] = a
updateIsLeaf a (x:xs) = Map.insert x False a'
    where a' = updateIsLeaf a xs

updateParentChildCount :: Map.Map Int Int -> Map.Map Int Bool -> Int -> Int -> Map.Map Int Int
updateParentChildCount childCount isLeaf parent node
    | (Map.lookup node isLeaf) == Nothing = childCount
    | fromJust (Map.lookup node isLeaf) == False = childCount
    | otherwise = Map.insertWith (+) parent 1 childCount

getFromMap :: Int -> Map.Map Int Bool -> Bool
getFromMap v m
    | Map.lookup v m == Nothing = False
    | otherwise = fromJust $ Map.lookup v m

isGood :: Map.Map Int Bool -> Bool -> Int -> Int -> Bool
isGood leafMap acc key value
    | isLeaf == True = acc
    | isLeaf == False = acc && (value >= 3)
    where isLeaf = getFromMap key leafMap

main :: IO ()
main = do
    n <- (read :: String -> Int) <$> getLine
    parents <- mapM (\_ -> (read :: String -> Int) <$> getLine) [1..(n - 1)]
    let emptyMap = Map.fromList $ zip [1..n] $ repeat True
        isLeafMap = updateIsLeaf emptyMap parents
        zeroChildCount = Map.fromList $ zip [1..n] [0,0..]
        updatedChildCount = foldl' (\m (a, b) -> updateParentChildCount m isLeafMap a b) zeroChildCount $ zip parents [2..]
        isSpruce = Map.foldlWithKey' (isGood isLeafMap) True updatedChildCount
    -- putStrLn . show $ updatedChildCount
    putStrLn $ if isSpruce then "Yes" else "No"

import qualified Data.Map as M
import qualified Data.Set as S

run :: Int -> [Int] -> Bool
run n l = let mm = M.fromList $ zip [1..n] (repeat S.empty)
              edges = foldr (\(idx, parent) m -> M.adjust (S.insert idx) parent m) mm (zip [2..n] l)
              leaves = M.keysSet (M.filter S.null edges)
          in all ((<=) 3 . S.size . S.filter (`S.member` leaves))  . filter (not . S.null) . map snd . M.toList $ edges

main :: IO ()
main = do
    n:l <- (map read . words) `fmap` getContents :: IO [Int]
    let ret = run n l
    putStrLn $ if ret then "Yes" else "No"

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

main = interact $ unlines . sol . (map read) . words

sol :: [Int] -> [String]
sol (_:xs) = wrap $ case soly (zip xs [2..]) 1 of
  Just _ -> "Yes"
  Nothing -> "No"

soly :: [(Int,Int)] -> Int -> Maybe Bool
soly ms t = case filter ((==t).fst) ms of
  [] -> Just True
  xs -> let ss = map ((soly ms).snd) xs
        in if (all isJust $ ss) && (3 <= (length $ filter ((==True).fromJust) ss))
            then Just False
            -- else Nothing
            else Nothing

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

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

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

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

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

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

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

addCnt :: [String] -> [String]
addCnt ls = (show $ length ls) : ls

toBitMap :: Int -> [(Int, Bool)]
toBitMap = toBitMap' 31
  where
    toBitMap' (-1) _ = []
    toBitMap' n v = (n, v .&. (1`shiftL`n) > 0) : toBitMap' (n-1) v
--------------------------------------------------------------------------------
pattern Empty   <- (S.viewl -> S.EmptyL)
pattern x :< xs <- (S.viewl -> x S.:< xs)
pattern xs :> x <- (S.viewr -> xs S.:> x)
--------------------------------------------------------------------------------

import Data.List

main = getContents >>= print . solve . map read . lines

solve (n:p') = if minimum lnum >= 3 then "Yes" else "No"
    where p = map pred p'
          leaf = filter (not . (`elem` p)) [1 .. n - 1]
          lp = [ p !! (x - 1) | x <- leaf]
          lnum = [ length $ elemIndices x lp | x <- p ]

import Control.Applicative
import Data.Maybe
import Data.List
import qualified Data.Map as Map

updateIsLeaf :: Map.Map Int Bool -> [Int] -> Map.Map Int Bool
updateIsLeaf a [] = a
updateIsLeaf a (x:xs) = Map.insert x False a'
    where a' = updateIsLeaf a xs

updateParentChildCount :: Map.Map Int Int -> Map.Map Int Bool -> Int -> Int -> Map.Map Int Int
updateParentChildCount childCount isLeaf parent node
    | (Map.lookup node isLeaf) == Nothing = childCount
    | fromJust (Map.lookup node isLeaf) == False = childCount
    | otherwise = Map.insertWith (+) parent 1 childCount

main :: IO ()
main = do
    n <- (read :: String -> Int) <$> getLine
    parents <- mapM (\_ -> (read :: String -> Int) <$> getLine) [1..(n - 1)]
    let emptyMap = Map.fromList $ zip [1..n] $ repeat True
        isLeafMap = updateIsLeaf emptyMap parents
        zeroChildCount = Map.fromList $ zip [1..n] [0,0..]
        updatedChildCount = foldl' (\m (a, b) -> updateParentChildCount m isLeafMap a b) zeroChildCount $ zip parents [2..]
        isSpruce = Map.foldl' (\x v -> x && (v == 0 || v >= 3)) True updatedChildCount
    putStrLn $ if isSpruce then "Yes" else "No"


This is the easy version of this problem. The only difference is the constraint on $$$k$$$ — the number of gifts in the offer. In this version: $$$k=2$$$.Vasya came to the store to buy goods for his friends for the New Year. It turned out that he was very lucky — today the offer "$$$k$$$ of goods for the price of one" is held in store. Remember, that in this problem $$$k=2$$$.Using this offer, Vasya can buy exactly $$$k$$$ of any goods, paying only for the most expensive of them. Vasya decided to take this opportunity and buy as many goods as possible for his friends with the money he has.More formally, for each good, its price is determined by $$$a_i$$$ — the number of coins it costs. Initially, Vasya has $$$p$$$ coins. He wants to buy the maximum number of goods. Vasya can perform one of the following operations as many times as necessary:  Vasya can buy one good with the index $$$i$$$ if he currently has enough coins (i.e $$$p \ge a_i$$$). After buying this good, the number of Vasya's coins will decrease by $$$a_i$$$, (i.e it becomes $$$p := p - a_i$$$).  Vasya can buy a good with the index $$$i$$$, and also choose exactly $$$k-1$$$ goods, the price of which does not exceed $$$a_i$$$, if he currently has enough coins (i.e $$$p \ge a_i$$$). Thus, he buys all these $$$k$$$ goods, and his number of coins decreases by $$$a_i$$$ (i.e it becomes $$$p := p - a_i$$$). Please note that each good can be bought no more than once.For example, if the store now has $$$n=5$$$ goods worth $$$a_1=2, a_2=4, a_3=3, a_4=5, a_5=7$$$, respectively, $$$k=2$$$, and Vasya has $$$6$$$ coins, then he can buy $$$3$$$ goods. A good with the index $$$1$$$ will be bought by Vasya without using the offer and he will pay $$$2$$$ coins. Goods with the indices $$$2$$$ and $$$3$$$ Vasya will buy using the offer and he will pay $$$4$$$ coins. It can be proved that Vasya can not buy more goods with six coins.Help Vasya to find out the maximum number of goods he can buy.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of test cases in the test. The next lines contain a description of $$$t$$$ test cases.  The first line of each test case contains three integers $$$n, p, k$$$ ($$$2 \le n \le 2 \cdot 10^5$$$, $$$1 \le p \le 2\cdot10^9$$$, $$$k=2$$$) — the number of goods in the store, the number of coins Vasya has and the number of goods that can be bought by the price of the most expensive of them. The second line of each test case contains $$$n$$$ integers $$$a_i$$$ ($$$1 \le a_i \le 10^4$$$) — the prices of goods. It is guaranteed that the sum of $$$n$$$ for all test cases does not exceed $$$2 \cdot 10^5$$$. It is guaranteed that in this version of the problem $$$k=2$$$ for all test cases.

For each test case in a separate line print one integer $$$m$$$ — the maximum number of goods that Vasya can buy.

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


There are some beautiful girls in Arpa’s land as mentioned before.Once Arpa came up with an obvious problem:Given an array and a number x, count the number of pairs of indices i, j (1 ≤ i < j ≤ n) such that , where  is bitwise xor operation (see notes for explanation).  Immediately, Mehrdad discovered a terrible solution that nobody trusted. Now Arpa needs your help to implement the solution to that problem.

First line contains two integers n and x (1 ≤ n ≤ 105, 0 ≤ x ≤ 105) — the number of elements in the array and the integer x. Second line contains n integers a1, a2, ..., an (1 ≤ ai ≤ 105) — the elements of the array.

Print a single integer: the answer to the problem.

NoteIn the first sample there is only one pair of i = 1 and j = 2.  so the answer is 1.In the second sample the only two pairs are i = 3, j = 4 (since ) and i = 1, j = 5 (since ).A bitwise xor takes two bit integers of equal length and performs the logical xor operation on each pair of corresponding bits. The result in each position is 1 if only the first bit is 1 or only the second bit is 1, but will be 0 if both are 0 or both are 1. You can read more about bitwise xor operation here: https://en.wikipedia.org/wiki/Bitwise_operation#XOR.

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 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           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 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 * (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


Valera had an undirected connected graph without self-loops and multiple edges consisting of n vertices. The graph had an interesting property: there were at most k edges adjacent to each of its vertices. For convenience, we will assume that the graph vertices were indexed by integers from 1 to n.One day Valera counted the shortest distances from one of the graph vertices to all other ones and wrote them out in array d. Thus, element d[i] of the array shows the shortest distance from the vertex Valera chose to vertex number i.Then something irreparable terrible happened. Valera lost the initial graph. However, he still has the array d. Help him restore the lost graph.

The first line contains two space-separated integers n and k (1 ≤ k < n ≤ 105). Number n shows the number of vertices in the original graph. Number k shows that at most k edges were adjacent to each vertex in the original graph. The second line contains space-separated integers d[1], d[2], ..., d[n] (0 ≤ d[i] < n). Number d[i] shows the shortest distance from the vertex Valera chose to the vertex number i.

If Valera made a mistake in his notes and the required graph doesn't exist, print in the first line number -1. Otherwise, in the first line print integer m (0 ≤ m ≤ 106) — the number of edges in the found graph. In each of the next m lines print two space-separated integers ai and bi (1 ≤ ai, bi ≤ n; ai ≠ bi), denoting the edge that connects vertices with numbers ai and bi. The graph shouldn't contain self-loops and multiple edges. If there are multiple possible answers, print any of them.

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

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