Let's define $$$f(x)$$$ for a positive integer $$$x$$$ as the length of the base-10 representation of $$$x$$$ without leading zeros. I like to call it a digital logarithm. Similar to a digital root, if you are familiar with that.You are given two arrays $$$a$$$ and $$$b$$$, each containing $$$n$$$ positive integers. In one operation, you do the following:   pick some integer $$$i$$$ from $$$1$$$ to $$$n$$$;  assign either $$$f(a_i)$$$ to $$$a_i$$$ or $$$f(b_i)$$$ to $$$b_i$$$. Two arrays are considered similar to each other if you can rearrange the elements in both of them, so that they are equal (e. g. $$$a_i = b_i$$$ for all $$$i$$$ from $$$1$$$ to $$$n$$$).What's the smallest number of operations required to make $$$a$$$ and $$$b$$$ similar to each other?

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of testcases. The first line of the testcase contains a single integer $$$n$$$ ($$$1 \le n \le 2 \cdot 10^5$$$) — the number of elements in each of the arrays. The second line contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i < 10^9$$$). The third line contains $$$n$$$ integers $$$b_1, b_2, \dots, b_n$$$ ($$$1 \le b_j < 10^9$$$). The sum of $$$n$$$ over all testcases doesn't exceed $$$2 \cdot 10^5$$$.

For each testcase, print the smallest number of operations required to make $$$a$$$ and $$$b$$$ similar to each other.

NoteIn the first testcase, you can apply the digital logarithm to $$$b_1$$$ twice.In the second testcase, the arrays are already similar to each other.In the third testcase, you can first apply the digital logarithm to $$$a_1$$$, then to $$$b_2$$$.

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when, liftM3)
import Data.Char (digitToInt, toLower)
import Data.Tuple
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.List (group, sort, intercalate)
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), find, sequenceA_, foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import Control.Monad.Trans.Class
import Control.Exception (assert)
import Data.String

-- type IMap = Set (Int, Int)
type Domain = (Heap, Heap)
type Solver  = Domain -> IO ()
-- type Heap = Set.MaxHeap Int
type Heap = Map.IntMap Int

fromList :: [Int] -> Heap
fromList = Map.fromListWith (+) . Prelude.map (,1)

heapInsert :: Int -> Heap -> Heap
heapInsert x = Map.insertWith (+) x 1

viewMax :: Heap -> Maybe (Int, Heap)
viewMax h
  | Map.null h = Nothing
  | otherwise =
    Just (k, if i == 1 then Map.deleteMax h else Map.insert k (i-1) h)
    where
      (k, i) = Map.findMax h

readChar8 :: IO [Int]
readChar8 = fmap (fst . fromJust) . fmap C.readInt . C.words <$> fromString <$> getLine

chunks :: Int -> [a] -> [[a]]
chunks _ [] = []
chunks n l
  | n > 0 = (take n l) : (chunks n (drop n l))
  | otherwise = error "Negative or zero n"

parse :: IO Domain
parse = do
  [n] <- readChar8
  xs <- readChar8
  ys <- readChar8
  return (fromList xs, fromList ys)

log10 :: Int -> Int
log10 x = if x < 10 then 1 else 1 + log10 (x `div` 10)

pushWithLog10 :: Int -> Heap -> Heap
pushWithLog10 x s = heapInsert (log10 x) s

-- (saving none)
-- the following all goes down to 1
-- 4. match the 1 to x: cost 1
-- 5. match 1 to n*x: cost 2
-- 6. match m to n*y : cost 3
-- 7. match m*x to n*y : cost 4
solve :: Solver
solve ps = print $ uncurry go ps
  where
    go xss yss = case (viewMax xss, viewMax yss) of
      (Just (x, xs) , Just (y, ys)) -> f
        where f
                | x == y = go xs ys
                | x < y = 1 + go xss (pushWithLog10 y ys)
                | x > y = 1 + go (pushWithLog10 x xs) yss
      _ -> 0

main :: IO ()
main = do
  [n] <- readChar8
  sequence_ =<< (replicateM n $ solve <$> parse)

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

{-# language NoMonomorphismRestriction #-}

{-# options_ghc -O3                              #-}

{-# options_ghc -Weverything                     #-}

{-# options_ghc -Wno-safe                        #-}     -- no warning if inferred as safe
{-# options_ghc -Wno-all-missed-specialisations  #-}     -- "Could not specialise..." when -O1
{-# options_ghc -Wno-missing-import-lists        #-}
{-# options_ghc -Wno-missing-local-signatures    #-}

-- (ghc -O1 -no-keep-o-files -no-keep-hi-files -rtsopts -o a.out *.hs  &&  set -o pipefail  &&  cat -- input.txt | ./a.out  &&  cat -- diglog.hs | xclip -selection clipboard  &&  echo COPIED  ||  echo ERROR)

import           Prelude               hiding (getLine)
import           Control.Arrow
import           Control.Monad
import qualified Data.ByteString.Char8 as B
import           Data.Char
import           Data.Function
import           Data.List
import qualified Data.Map.Strict       as Map
import           Data.Maybe
import           Data.Tuple

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

both f (a,b) = (f a, f b)

diglog n = (length . show) (n::Int)

applyIf p f x | (p x)      = f x
              | otherwise  = x

justIfNonzero n | (n >  0)   = Just n
                | (n == 0)   = Nothing
                | otherwise  = error "Logic error (neg cnt)"

main :: IO ()
main = do
    [t] <- ri
    tcs <- replicateM t $ do
        [_n] <- ri
        replicateM 2 ri
    mapM_ (putStrLn.show.solve) tcs

solve [xs,ys] = cntLarge + cntReduceTo1 + cntReduceBoth
  where
    bothRm f = removeCommonElems . both f

    s1 @(_,_) = bothRm (Map.fromListWith (+) . (`zip` ones)) $ (xs,ys)

    s3 @(_,_) = bothRm (Map.mapKeysWith (+) (applyIf isLarge diglog)) $ s1

    s41@(_,_) =        reduce1        $ s3
    s42@(_,_) = swap . reduce1 . swap $ s41

    isLarge = (>9)

    cntLarge = sum . map snd . filter (isLarge.fst) . uncurry (++) . both Map.toList $ s1

    cntReduceTo1 = ((-) `on` (mapLen.fst)) s3 s42

    cntReduceBoth = (*2) . mapLen . fst $ s42

solve _ =
    error "Wrong input parsing"

removeCommonElems (xm,ym) = (xxm,yym)
  where
    common = (Map.intersectionWith min) xm ym
    (xxm,yym) = both (mapsub common) (xm,ym)

    mapsub = flip (Map.differenceWith f)  where  f a b = justIfNonzero (a - b)

reduce1 = until (not.p) f
  where
    p (xm,ym) = (1 `Map.member` ym) && (not.null $ xm)

    f (xm,ym) = (reduceByOne xkey xm,
                 reduceByOne 1    ym)
      where
        reduceByOne = Map.update (justIfNonzero . pred)

        xkey = fst . fromJust . Map.lookupGE 0 $ xm  -- any key from xm

mapLen = Map.foldl (+) 0

ones = [1,1..] :: [Int]

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when, liftM3)
import Data.Char (digitToInt, toLower)
import Data.Tuple
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort, intercalate)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.IntMap as Map
import Data.IntMap
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), find, sequenceA_, foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import Control.Monad.Trans.Class
import Control.Exception (assert)
import Data.String

-- type IMap = Set (Int, Int)
type Domain = (IntMap Int, IntMap Int)
type Solver  = Domain -> IO ()

readChar8 :: IO [Int]
readChar8 = fmap (fst . fromJust) . fmap C.readInt . C.words <$> fromString <$> getLine

chunks :: Int -> [a] -> [[a]]
chunks _ [] = []
chunks n l
  | n > 0 = (take n l) : (chunks n (drop n l))
  | otherwise = error "Negative or zero n"

parse :: IO Domain
parse = do
  [n] <- readChar8
  xs <- readChar8
  ys <- readChar8
  -- let target = [295, 268, 276, 153, 153, 296, 61]
  -- if take (length target) xs == target
  --   then mapM_ print (chunks 20 ys)
  --   else return ()
  return (toCount xs, toCount ys)

enumerate :: [a] -> [(Int, a)]
enumerate xs = zip [1..length xs] xs

toCount :: [Int] -> IntMap Int
toCount xs = Map.fromListWith (+) (zip xs $ cycle [1])

-- sub if k have the same length as in gs
subValue :: IntMap Int -> Int -> Int -> (IntMap Int, Int)
subValue gs k c
  | l `Map.member` gs = (subCount gs l cSub, c - cSub)
  | otherwise = (gs,c)
  where
    l = log10  k
    cSub = min (gs Map.! l) c

subCount :: IntMap Int -> Int -> Int -> IntMap Int
subCount count k i = Map.update (\x -> Just (x - i)) k count

unfold :: [(Int, Int)] -> [Int]
unfold [] = []
unfold ((x,n):rest) = replicate n x++unfold rest

kill0 :: IntMap Int -> IntMap Int
kill0 = Map.filter (/=0)
-- 1: no change
-- x: 1:1
-- n*x: 1:n 2:1
-- toBothList :: (IntMap Int, IntMap Int) -> ([(Int, Int)], [(Int, Int)])
toBothList (xs, ys) = (toDebugList xs, toDebugList ys)

toDebugList  x = (length y,y)
  where y = unfold $ Map.toAscList x

domainDiff (a, b) (x, y)= (diff a x, diff  b y)

log10 :: Int -> Int
log10 x = if x < 10 then 1 else 1 + log10 (x `div` 10)

diff :: IntMap Int -> IntMap Int -> IntMap Int
diff = (kill0.) . (Map.differenceWith ((Just .). (-)))

foldWithSavings :: [Domain -> (Int, Domain)] -> Domain -> ([Int], Domain)
foldWithSavings fs d = Prelude.foldl (\(s,d) f -> let (s',d') = f d in
      let (k1,k2) = toBothList $ domainDiff d d'
      in traceShow s' $ traceShow k1 $ traceShow k2 $ traceShow "-------"$ (s':s,d')) ([],d) fs

-- 1. cancellate all matched: cost 0
cancellateMatched :: Domain -> (Int, Domain)
cancellateMatched (xs, ys) = (savings, (xms, yms))
  where common = Map.intersectionWith min xs ys
        xms = Map.unionWith (-) xs common
        yms = Map.unionWith (-) ys common
        savings = sum $ Map.elems $ Map.mapWithKey computeSave common
        computeSave k v
          | k == 1 = 0
          | k < 10 = 2 * v
          | otherwise = 4 * v

-- 2. match the n to n*x digit: cost 1(saving 2)
matchN :: Domain -> (Int, Domain)
matchN xs = (savings1 + savings2, swap nnxs)
  where
    (savings1, nxs) = matchN' xs
    (savings2, nnxs) =  matchN' $ swap nxs
matchN' :: Domain -> (Int, Domain)
matchN' (xs, ys) = (savings, (nxs, nys))
  where ns = Map.filterWithKey (\k _ -> k > 1 && k < 10) xs
        -- sub if k have the same length as in gs
        (resGs, nys) = (id *** kill0) $ Map.mapAccumWithKey subValue ns ys
        nxs =  kill0 $ unionWith (const) resGs xs
        savings = sum $ Map.elems $ Map.map (2*) (differenceWith (\x y -> Just $ x - y) ns resGs)

-- 3. match n*x to n*y : cost 2 (saving 2, n > 2)
matchNN :: Domain -> (Int, Domain)
matchNN (xs, ys) = (savings, (nxs, nys))
  where
        filter1 = Map.filterWithKey (\k _ -> k > 1)
        xls =  filter1 $ Map.mapKeysWith (+) (log10 ) xs
        yls =  filter1 $ Map.mapKeysWith (+) (log10 ) ys
        common = Map.intersectionWith min xls yls
        nxs = kill0 . snd $ Map.mapAccumWithKey subValue common xs
        nys = kill0 . snd $ Map.mapAccumWithKey subValue common ys
        savings = sum $ Map.elems $ Map.map (2*) common

cost :: IntMap Int -> Int
cost = sum . Map.elems . Map.mapWithKey computeCost
  where computeCost k v
            | k == 1 = 0
            | log10 k == 1 = 1 * v
            | otherwise = 2 * v

-- (saving none)
-- the following all goes down to 1
-- 4. match the 1 to x: cost 1
-- 5. match 1 to n*x: cost 2
-- 6. match m to n*y : cost 3
-- 7. match m*x to n*y : cost 4
solve :: Solver
solve xs =
  traceShow (totalCost, savings, rest)$
  print (totalCost - sum savings)
  where
    (savings, rest) = foldWithSavings [cancellateMatched, matchN, matchNN] xs
    totalCost = cost (uncurry (unionWith (+)) xs)

ccount :: ([Int], [Int], [Int]) -> (Int, Int, Int)
ccount (xs, ys, zs) = (length xs, length ys, length zs)

go :: [Int] -> ([Int], [Int], [Int])
go [] = ([],[],[])
go (x:xs)
  | x == 1 = (x:as, bs, cs)
  | x > 10 = (as, bs, x:cs)
  | otherwise = (as, x:bs, cs)
  where (as,bs,cs) = go xs

x1 = [295,268,276,153,153,296,61,4,150,145,62,64,109,132,250,265,85,56,297,224]
x2= [38,32,130,254,141,6,250,34,255,14,115,207,75,268,150,144,177,46,177,242]
x3= [243,220,266,205,187,165,207,211,291,233,251,108,200,37,203,289,48,129,222,61]
x4= [285,34,296,47,291,285,149,134,217,166,75,270,189,114,259,170,67,213,257,245]

y1 =[95,284,23,184,124,77,282,159,229,186,192,155,31,146,51,138,149,64,241,23]
y2=[219,298,54,174,84,19,54,86,5,289,12,78,15,259,248,262,136,233,121,76]
y3=[131,183,68,133,187,298,143,188,64,31,275,255,127,193,282,189,109,35,106,81]
y4=[255,276,168,74,293,174,78,140,194,291,218,233,98,179,244,18,185,180,20,94]

cc :: (Int, Int, Int) -> Int
cc (a, b, c) = b + 2 * c

main :: IO ()
main = do
  [n] <- readChar8
  let xs = x1 ++ x2 ++ x3 ++ x4
  let ys = y1 ++ y2 ++ y3 ++ y4
  print $ ccount $ go  xs
  print $ ccount $ go  ys
  print $ cc $ ccount $ go  xs
  print $ cc $ ccount $ go  ys
  sequence_ =<< (replicateM n $ solve <$> return (toCount xs, toCount ys))

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when, liftM3)
import Data.Char (digitToInt, toLower)
import Data.Tuple
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort, intercalate)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.IntMap as Map
import Data.IntMap
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), find, sequenceA_, foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import Control.Monad.Trans.Class
import Control.Exception (assert)
import Data.String

-- type IMap = Set (Int, Int)
type Domain = (IntMap Int, IntMap Int)
type Solver  = Domain -> IO ()

readChar8 :: IO [Int]
readChar8 = fmap (fst . fromJust) . fmap C.readInt . C.words <$> fromString <$> getLine

chunks :: Int -> [a] -> [[a]]
chunks _ [] = []
chunks n l
  | n > 0 = (take n l) : (chunks n (drop n l))
  | otherwise = error "Negative or zero n"

parse :: IO Domain
parse = do
  [n] <- readChar8
  xs <- readChar8
  ys <- readChar8
  let target = [295, 268, 276, 153, 153, 296, 61]
  if take (length target) xs == target
    then mapM_ print (chunks 20 ys)
    else return ()
  return (toCount xs, toCount ys)

enumerate :: [a] -> [(Int, a)]
enumerate xs = zip [1..length xs] xs

toCount :: [Int] -> IntMap Int
toCount xs = Map.fromListWith (+) (zip xs $ cycle [1])

-- sub if k have the same length as in gs
subValue :: IntMap Int -> Int -> Int -> (IntMap Int, Int)
subValue gs k c
  | l `Map.member` gs = (subCount gs l cSub, c - cSub)
  | otherwise = (gs,c)
  where
    l = length $ show k
    cSub = min (gs Map.! l) c

subCount :: IntMap Int -> Int -> Int -> IntMap Int
subCount count k i = Map.update (\x -> Just (x - i)) k count

kill0 :: IntMap Int -> IntMap Int
kill0 = Map.filter (/=0)
-- 1: no change
-- x: 1:1
-- n*x: 1:n 2:1

domainDiff (a, b) (x, y)= (Map.difference a x, Map.difference b y)

foldWithSavings :: [Domain -> (Int, Domain)] -> Domain -> ([Int], Domain)
foldWithSavings fs d = Prelude.foldl (\(s,d) f -> let (s',d') = f d in
      -- traceShow (s',domainDiff d d')
      (s':s,d')) ([],d) fs

-- 1. cancellate all matched: cost 0
cancellateMatched :: Domain -> (Int, Domain)
cancellateMatched (xs, ys) = (savings, (xms, yms))
  where common = Map.intersectionWith min xs ys
        xms = kill0 $ Map.unionWith (-) xs common
        yms = kill0 $ Map.unionWith (-) ys common
        savings = sum $ Map.elems $ Map.mapWithKey computeSave common
        computeSave k v
          | k == 1 = 0
          | k < 10 = 2 * v
          | otherwise = 4 * v

-- 2. match the n to n*x digit: cost 1(saving 2)
matchN :: Domain -> (Int, Domain)
matchN xs = (savings1 + savings2, nnxs)
  where
    (savings1, nxs) = matchN' xs
    (savings2, nnxs) =  matchN' $ swap nxs
matchN' :: Domain -> (Int, Domain)
matchN' (xs, ys) = (savings, (nxs, nys))
  where ns = Map.filterWithKey (\k _ -> k > 1 && k < 10) xs
        -- sub if k have the same length as in gs
        (resGs, nys) = (id *** kill0) $ Map.mapAccumWithKey subValue ns ys
        nxs =  kill0 $ unionWith (const) resGs xs
        savings = sum $ Map.elems $ Map.map (2*) (differenceWith (\x y -> Just $ x - y) ns resGs)

-- 3. match n*x to n*y : cost 2(saving 2)
matchNN :: Domain -> (Int, Domain)
matchNN (xs, ys) = (savings, (nxs, nys))
  where
        xls =  Map.mapKeysWith (+) (length . show)$ Map.filterWithKey (\k _ -> k > 1)  xs
        yls =  Map.mapKeysWith (+) (length . show)$ Map.filterWithKey (\k _ -> k > 1)  ys
        common = Map.intersectionWith min xls yls
        nxs = kill0 . snd $ Map.mapAccumWithKey subValue common xs
        nys = kill0 . snd $ Map.mapAccumWithKey subValue common ys
        savings = sum $ Map.elems $ Map.map (2*) common

cost :: IntMap Int -> Int
cost = sum . Map.elems . Map.mapWithKey computeCost
  where computeCost k v
            | k == 1 = 0
            | length (show k) == 1 = 1 * v
            | otherwise = 2 * v

-- (saving none)
-- the following all goes down to 1
-- 4. match the 1 to x: cost 1
-- 5. match 1 to n*x: cost 2
-- 6. match m to n*y : cost 3
-- 7. match m*x to n*y : cost 4
solve :: Solver
solve xs =
  -- traceShow (rest, totalCost, savings)$
  print (totalCost - sum savings)
  where
    (savings, rest) = foldWithSavings [cancellateMatched, matchNN, matchN] xs
    totalCost = cost (uncurry (unionWith (+)) xs)

x1 = [295,268,276,153,153,296,61,4,150,145,62,64,109,132,250,265,85,56,297,224]
x2= [38,32,130,254,141,6,250,34,255,14,115,207,75,268,150,144,177,46,177,242]
x3= [243,220,266,205,187,165,207,211,291,233,251,108,200,37,203,289,48,129,222,61]
x4= [285,34,296,47,291,285,149,134,217,166,75,270,189,114,259,170,67,213,257,245]

main :: IO ()
main = do
  [n] <- readChar8
  sequence_ =<< (replicateM n $ solve <$> parse)

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when, liftM3)
import Data.Char (digitToInt, toLower)
import Data.Tuple
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort, intercalate)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.IntMap as Map
import Data.IntMap
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), find, sequenceA_, foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import Control.Monad.Trans.Class
import Control.Exception (assert)
import Data.String

-- type IMap = Set (Int, Int)
type Domain = (IntMap Int, IntMap Int)
type Solver  = Domain -> IO ()

readChar8 :: IO [Int]
readChar8 = fmap (fst . fromJust) . fmap C.readInt . C.words <$> fromString <$> getLine

chunks :: Int -> [a] -> [[a]]
chunks _ [] = []
chunks n l
  | n > 0 = (take n l) : (chunks n (drop n l))
  | otherwise = error "Negative or zero n"

parse :: IO Domain
parse = do
  [n] <- readChar8
  xs <- readChar8
  ys <- readChar8
  let target = [295, 268, 276, 153, 153, 296, 61]
  if take (length target) xs == target
    then mapM_ print (chunks 20 xs) >>  mapM_ print (chunks 20 ys)
    else return ()
  return (toCount xs, toCount ys)

enumerate :: [a] -> [(Int, a)]
enumerate xs = zip [1..length xs] xs

toCount :: [Int] -> IntMap Int
toCount xs = Map.fromListWith (+) (zip xs $ cycle [1])

-- sub if k have the same length as in gs
subValue :: IntMap Int -> Int -> Int -> (IntMap Int, Int)
subValue gs k c
  | l `Map.member` gs = (subCount gs l cSub, c - cSub)
  | otherwise = (gs,c)
  where
    l = length $ show k
    cSub = min (gs Map.! l) c

subCount :: IntMap Int -> Int -> Int -> IntMap Int
subCount count k i = Map.update (\x -> Just (x - i)) k count

kill0 :: IntMap Int -> IntMap Int
kill0 = Map.filter (/=0)
-- 1: no change
-- x: 1:1
-- n*x: 1:n 2:1

domainDiff (a, b) (x, y)= (Map.difference a x, Map.difference b y)

foldWithSavings :: [Domain -> (Int, Domain)] -> Domain -> ([Int], Domain)
foldWithSavings fs d = Prelude.foldl (\(s,d) f -> let (s',d') = f d in
      -- traceShow (s',domainDiff d d')
      (s':s,d')) ([],d) fs

-- 1. cancellate all matched: cost 0
cancellateMatched :: Domain -> (Int, Domain)
cancellateMatched (xs, ys) = (savings, (xms, yms))
  where common = Map.intersectionWith min xs ys
        xms = kill0 $ Map.unionWith (-) xs common
        yms = kill0 $ Map.unionWith (-) ys common
        savings = sum $ Map.elems $ Map.mapWithKey computeSave common
        computeSave k v
          | k == 1 = 0
          | k < 10 = 2 * v
          | otherwise = 4 * v

-- 2. match the n to n*x digit: cost 1(saving 2)
matchN :: Domain -> (Int, Domain)
matchN xs = (savings1 + savings2, nnxs)
  where
    (savings1, nxs) = matchN' xs
    (savings2, nnxs) =  matchN' $ swap nxs
matchN' :: Domain -> (Int, Domain)
matchN' (xs, ys) = (savings, (nxs, nys))
  where ns = Map.filterWithKey (\k _ -> k > 1 && k < 10) xs
        -- sub if k have the same length as in gs
        (resGs, nys) = (id *** kill0) $ Map.mapAccumWithKey subValue ns ys
        nxs =  kill0 $ unionWith (const) resGs xs
        savings = sum $ Map.elems $ Map.map (2*) (differenceWith (\x y -> Just $ x - y) ns resGs)

-- 3. match n*x to n*y : cost 2(saving 2)
matchNN :: Domain -> (Int, Domain)
matchNN (xs, ys) = (savings, (nxs, nys))
  where
        xls =  Map.mapKeysWith (+) (length . show)$ Map.filterWithKey (\k _ -> k > 1)  xs
        yls =  Map.mapKeysWith (+) (length . show)$ Map.filterWithKey (\k _ -> k > 1)  ys
        common = Map.intersectionWith min xls yls
        nxs = kill0 . snd $ Map.mapAccumWithKey subValue common xs
        nys = kill0 . snd $ Map.mapAccumWithKey subValue common ys
        savings = sum $ Map.elems $ Map.map (2*) common

cost :: IntMap Int -> Int
cost = sum . Map.elems . Map.mapWithKey computeCost
  where computeCost k v
            | k == 1 = 0
            | length (show k) == 1 = 1 * v
            | otherwise = 2 * v

-- (saving none)
-- the following all goes down to 1
-- 4. match the 1 to x: cost 1
-- 5. match 1 to n*x: cost 2
-- 6. match m to n*y : cost 3
-- 7. match m*x to n*y : cost 4
solve :: Solver
solve xs =
  -- traceShow (rest, totalCost, savings)$
  print (totalCost - sum savings)
  where
    (savings, rest) = foldWithSavings [cancellateMatched, matchNN, matchN] xs
    totalCost = cost (uncurry (unionWith (+)) xs)

main :: IO ()
main = do
  [n] <- readChar8
  sequence_ =<< (replicateM n $ solve <$> parse)

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when, liftM3)
import Data.Char (digitToInt, toLower)
import Data.Tuple
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort, intercalate)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.IntMap as Map
import Data.IntMap
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), find, sequenceA_, foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import Control.Monad.Trans.Class
import Control.Exception (assert)
import Data.String

-- type IMap = Set (Int, Int)
type Domain = (IntMap Int, IntMap Int)
type Solver  = Domain -> IO ()

readChar8 :: IO [Int]
readChar8 = fmap (fst . fromJust) . fmap C.readInt . C.words <$> fromString <$> getLine

chunks :: Int -> [a] -> [[a]]
chunks _ [] = []
chunks n l
  | n > 0 = (take n l) : (chunks n (drop n l))
  | otherwise = error "Negative or zero n"

parse :: IO Domain
parse = do
  [n] <- readChar8
  xs <- readChar8
  ys <- readChar8
  let target = [295, 268, 276, 153, 153, 296, 61]
  if take (length target) xs == target
    then mapM_ print $ chunks 20 xs
    else return ()
  return (toCount xs, toCount ys)

enumerate :: [a] -> [(Int, a)]
enumerate xs = zip [1..length xs] xs

toCount :: [Int] -> IntMap Int
toCount xs = Map.fromListWith (+) (zip xs $ cycle [1])

-- sub if k have the same length as in gs
subValue :: IntMap Int -> Int -> Int -> (IntMap Int, Int)
subValue gs k c
  | l `Map.member` gs = (subCount gs l cSub, c - cSub)
  | otherwise = (gs,c)
  where
    l = length $ show k
    cSub = min (gs Map.! l) c

subCount :: IntMap Int -> Int -> Int -> IntMap Int
subCount count k i = Map.update (\x -> Just (x - i)) k count

kill0 :: IntMap Int -> IntMap Int
kill0 = Map.filter (/=0)
-- 1: no change
-- x: 1:1
-- n*x: 1:n 2:1

domainDiff (a, b) (x, y)= (Map.difference a x, Map.difference b y)

foldWithSavings :: [Domain -> (Int, Domain)] -> Domain -> ([Int], Domain)
foldWithSavings fs d = Prelude.foldl (\(s,d) f -> let (s',d') = f d in
      -- traceShow (s',domainDiff d d')
      (s':s,d')) ([],d) fs

-- 1. cancellate all matched: cost 0
cancellateMatched :: Domain -> (Int, Domain)
cancellateMatched (xs, ys) = (savings, (xms, yms))
  where common = Map.intersectionWith min xs ys
        xms = kill0 $ Map.unionWith (-) xs common
        yms = kill0 $ Map.unionWith (-) ys common
        savings = sum $ Map.elems $ Map.mapWithKey computeSave common
        computeSave k v
          | k == 1 = 0
          | k < 10 = 2 * v
          | otherwise = 4 * v

-- 2. match the n to n*x digit: cost 1(saving 2)
matchN :: Domain -> (Int, Domain)
matchN xs = (savings1 + savings2, nnxs)
  where
    (savings1, nxs) = matchN' xs
    (savings2, nnxs) =  matchN' $ swap nxs
matchN' :: Domain -> (Int, Domain)
matchN' (xs, ys) = (savings, (nxs, nys))
  where ns = Map.filterWithKey (\k _ -> k > 1 && k < 10) xs
        -- sub if k have the same length as in gs
        (resGs, nys) = (id *** kill0) $ Map.mapAccumWithKey subValue ns ys
        nxs =  kill0 $ unionWith (const) resGs xs
        savings = sum $ Map.elems $ Map.map (2*) (differenceWith (\x y -> Just $ x - y) ns resGs)

-- 3. match n*x to n*y : cost 2(saving 2)
matchNN :: Domain -> (Int, Domain)
matchNN (xs, ys) = (savings, (nxs, nys))
  where
        xls =  Map.mapKeysWith (+) (length . show)$ Map.filterWithKey (\k _ -> k > 1)  xs
        yls =  Map.mapKeysWith (+) (length . show)$ Map.filterWithKey (\k _ -> k > 1)  ys
        common = Map.intersectionWith min xls yls
        nxs = kill0 . snd $ Map.mapAccumWithKey subValue common xs
        nys = kill0 . snd $ Map.mapAccumWithKey subValue common ys
        savings = sum $ Map.elems $ Map.map (2*) common

cost :: IntMap Int -> Int
cost = sum . Map.elems . Map.mapWithKey computeCost
  where computeCost k v
            | k == 1 = 0
            | length (show k) == 1 = 1 * v
            | otherwise = 2 * v

-- (saving none)
-- the following all goes down to 1
-- 4. match the 1 to x: cost 1
-- 5. match 1 to n*x: cost 2
-- 6. match m to n*y : cost 3
-- 7. match m*x to n*y : cost 4
solve :: Solver
solve xs =
  -- traceShow (rest, totalCost, savings)$
  print (totalCost - sum savings)
  where
    (savings, rest) = foldWithSavings [cancellateMatched, matchNN, matchN] xs
    totalCost = cost (uncurry (unionWith (+)) xs)

main :: IO ()
main = do
  [n] <- readChar8
  sequence_ =<< (replicateM n $ solve <$> parse)

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when, liftM3)
import Data.Char (digitToInt, toLower)
import Data.Tuple
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort, intercalate)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.IntMap as Map
import Data.IntMap
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), find, sequenceA_, foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import Control.Monad.Trans.Class
import Control.Exception (assert)
import Data.String

-- type IMap = Set (Int, Int)
type Domain = (IntMap Int, IntMap Int)
type Solver  = Domain -> IO ()

readChar8 :: IO [Int]
readChar8 = fmap (fst . fromJust) . fmap C.readInt . C.words <$> fromString <$> getLine

parse :: IO Domain
parse = do
  [n] <- readChar8
  xs <- readChar8
  ys <- readChar8
  let target = [295, 268, 276, 153, 153, 296, 61]
  if take (length target) xs == target
    then print xs
    else return ()
  return (toCount xs, toCount ys)

enumerate :: [a] -> [(Int, a)]
enumerate xs = zip [1..length xs] xs

toCount :: [Int] -> IntMap Int
toCount xs = Map.fromListWith (+) (zip xs $ cycle [1])

-- sub if k have the same length as in gs
subValue :: IntMap Int -> Int -> Int -> (IntMap Int, Int)
subValue gs k c
  | l `Map.member` gs = (subCount gs l cSub, c - cSub)
  | otherwise = (gs,c)
  where
    l = length $ show k
    cSub = min (gs Map.! l) c

subCount :: IntMap Int -> Int -> Int -> IntMap Int
subCount count k i = Map.update (\x -> Just (x - i)) k count

kill0 :: IntMap Int -> IntMap Int
kill0 = Map.filter (/=0)
-- 1: no change
-- x: 1:1
-- n*x: 1:n 2:1

domainDiff (a, b) (x, y)= (Map.difference a x, Map.difference b y)

foldWithSavings :: [Domain -> (Int, Domain)] -> Domain -> ([Int], Domain)
foldWithSavings fs d = Prelude.foldl (\(s,d) f -> let (s',d') = f d in
      -- traceShow (s',domainDiff d d')
      (s':s,d')) ([],d) fs

-- 1. cancellate all matched: cost 0
cancellateMatched :: Domain -> (Int, Domain)
cancellateMatched (xs, ys) = (savings, (xms, yms))
  where common = Map.intersectionWith min xs ys
        xms = kill0 $ Map.unionWith (-) xs common
        yms = kill0 $ Map.unionWith (-) ys common
        savings = sum $ Map.elems $ Map.mapWithKey computeSave common
        computeSave k v
          | k == 1 = 0
          | k < 10 = 2 * v
          | otherwise = 4 * v

-- 2. match the n to n*x digit: cost 1(saving 2)
matchN :: Domain -> (Int, Domain)
matchN xs = (savings1 + savings2, nnxs)
  where
    (savings1, nxs) = matchN' xs
    (savings2, nnxs) =  matchN' $ swap nxs
matchN' :: Domain -> (Int, Domain)
matchN' (xs, ys) = (savings, (nxs, nys))
  where ns = Map.filterWithKey (\k _ -> k > 1 && k < 10) xs
        -- sub if k have the same length as in gs
        (resGs, nys) = (id *** kill0) $ Map.mapAccumWithKey subValue ns ys
        nxs =  kill0 $ unionWith (const) resGs xs
        savings = sum $ Map.elems $ Map.map (2*) (differenceWith (\x y -> Just $ x - y) ns resGs)

-- 3. match n*x to n*y : cost 2(saving 2)
matchNN :: Domain -> (Int, Domain)
matchNN (xs, ys) = (savings, (nxs, nys))
  where
        xls =  Map.mapKeysWith (+) (length . show)$ Map.filterWithKey (\k _ -> k > 1)  xs
        yls =  Map.mapKeysWith (+) (length . show)$ Map.filterWithKey (\k _ -> k > 1)  ys
        common = Map.intersectionWith min xls yls
        nxs = kill0 . snd $ Map.mapAccumWithKey subValue common xs
        nys = kill0 . snd $ Map.mapAccumWithKey subValue common ys
        savings = sum $ Map.elems $ Map.map (2*) common

cost :: IntMap Int -> Int
cost = sum . Map.elems . Map.mapWithKey computeCost
  where computeCost k v
            | k == 1 = 0
            | length (show k) == 1 = 1 * v
            | otherwise = 2 * v

-- (saving none)
-- the following all goes down to 1
-- 4. match the 1 to x: cost 1
-- 5. match 1 to n*x: cost 2
-- 6. match m to n*y : cost 3
-- 7. match m*x to n*y : cost 4
solve :: Solver
solve xs =
  -- traceShow (rest, totalCost, savings)$
  print (totalCost - sum savings)
  where
    (savings, rest) = foldWithSavings [cancellateMatched, matchNN, matchN] xs
    totalCost = cost (uncurry (unionWith (+)) xs)

main :: IO ()
main = do
  [n] <- readChar8
  sequence_ =<< (replicateM n $ solve <$> parse)

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when, liftM3)
import Data.Char (digitToInt, toLower)
import Data.Tuple
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort, intercalate)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.IntMap as Map
import Data.IntMap
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), find, sequenceA_, foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import Control.Monad.Trans.Class
import Control.Exception (assert)
import Data.String

-- type IMap = Set (Int, Int)
type Domain = (IntMap Int, IntMap Int)
type Solver  = Domain -> IO ()

readChar8 :: IO [Int]
readChar8 = fmap (fst . fromJust) . fmap C.readInt . C.words <$> fromString <$> getLine

parse :: IO Domain
parse = do
  [n] <- readChar8
  xs <- readChar8
  ys <- readChar8
  return (toCount xs, toCount ys)

enumerate :: [a] -> [(Int, a)]
enumerate xs = zip [1..length xs] xs

toCount :: [Int] -> IntMap Int
toCount xs = Map.fromListWith (+) (zip xs $ cycle [1])

-- sub if k have the same length as in gs
subValue :: IntMap Int -> Int -> Int -> (IntMap Int, Int)
subValue gs k c
  | l `Map.member` gs = (subCount gs l cSub, c - cSub)
  | otherwise = (gs,c)
  where
    l = length $ show k
    cSub = min (gs Map.! l) c

subCount :: IntMap Int -> Int -> Int -> IntMap Int
subCount count k i = Map.update (\x -> Just (x - i)) k count

kill0 :: IntMap Int -> IntMap Int
kill0 = Map.filter (/=0)
-- 1: no change
-- x: 1:1
-- n*x: 1:n 2:1

domainDiff (a, b) (x, y)= (Map.difference a x, Map.difference b y)

foldWithSavings :: [Domain -> (Int, Domain)] -> Domain -> ([Int], Domain)
foldWithSavings fs d = Prelude.foldl (\(s,d) f -> let (s',d') = f d in
      -- traceShow (s',domainDiff d d')
      (s':s,d')) ([],d) fs

-- 1. cancellate all matched: cost 0
cancellateMatched :: Domain -> (Int, Domain)
cancellateMatched (xs, ys) = (savings, (xms, yms))
  where common = Map.intersectionWith min xs ys
        xms = kill0 $ Map.unionWith (-) xs common
        yms = kill0 $ Map.unionWith (-) ys common
        savings = sum $ Map.elems $ Map.mapWithKey computeSave common
        computeSave k v
          | k == 1 = 0
          | k < 10 = 2 * v
          | otherwise = 4 * v

-- 2. match the n to n*x digit: cost 1(saving 2)
matchN :: Domain -> (Int, Domain)
matchN xs = (savings1 + savings2, nnxs)
  where
    (savings1, nxs) = matchN' xs
    (savings2, nnxs) =  matchN' $ swap nxs
matchN' :: Domain -> (Int, Domain)
matchN' (xs, ys) = traceShow  ((nxs, nys), gs)  (savings, (nxs, nys))
  where gs = Map.filterWithKey (\k _ -> k > 1 && k < 10) xs
        -- sub if k have the same length as in gs
        (resGs, nys) = (id *** kill0) $ Map.mapAccumWithKey subValue gs ys
        nxs =  kill0 $ unionWith (const) resGs xs
        savings = sum $ Map.elems $ Map.map (2*) (differenceWith (\x y -> Just $ x - y) gs resGs)

-- 3. match n*x to n*y : cost 2(saving 2)
matchNN :: Domain -> (Int, Domain)
matchNN (xs, ys) = (savings, (nxs, nys))
  where

        xls =  Map.mapKeysWith (+) (length . show)$ Map.filterWithKey (\k _ -> k > 1)  xs
        yls =  Map.mapKeysWith (+) (length . show)$ Map.filterWithKey (\k _ -> k > 1)  ys
        common = Map.intersectionWith min xls yls
        nxs = kill0 . snd $ Map.mapAccumWithKey subValue common xs
        nys = kill0 . snd $ Map.mapAccumWithKey subValue common ys
        savings = sum $ Map.elems $ Map.map (2*) common

cost :: IntMap Int -> Int
cost = sum . Map.elems . Map.mapWithKey computeCost
  where computeCost k v
            | k == 1 = 0
            | length (show k) == 1 = 1 * v
            | otherwise = 2 * v

-- (saving none)
-- the following all goes down to 1
-- 4. match the 1 to x: cost 1
-- 5. match 1 to n*x: cost 2
-- 6. match m to n*y : cost 3
-- 7. match m*x to n*y : cost 4
solve :: Solver
solve xs =
  traceShow (rest, totalCost, savings)$
  print (totalCost - sum savings)
  where
    (savings, rest) = foldWithSavings [cancellateMatched, matchNN, matchN] xs
    totalCost = cost (uncurry (unionWith (+)) xs)

main :: IO ()
main = do
  [n] <- readChar8
  sequence_ =<< (replicateM n $ solve <$> parse)

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when, liftM3)
import Data.Char (digitToInt, toLower)
import Data.Tuple
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort, intercalate)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.IntMap as Map
import Data.IntMap
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), find, sequenceA_, foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import Control.Monad.Trans.Class
import Control.Exception (assert)
import Data.String

-- type IMap = Set (Int, Int)
type Domain = (IntMap Int, IntMap Int)
type Solver  = Domain -> IO ()

readChar8 :: IO [Int]
readChar8 = fmap (fst . fromJust) . fmap C.readInt . C.words <$> fromString <$> getLine

parse :: IO Domain
parse = do
  [n] <- readChar8
  xs <- readChar8
  ys <- readChar8
  return (toCount xs, toCount ys)

enumerate :: [a] -> [(Int, a)]
enumerate xs = zip [1..length xs] xs

toCount :: [Int] -> IntMap Int
toCount xs = Map.fromListWith (+) (zip xs $ cycle [1])

-- sub if k have the same length as in gs
subValue :: IntMap Int -> Int -> Int -> (IntMap Int, Int)
subValue gs k c
  | l `Map.member` gs = (subCount gs l cSub, c - cSub)
  | otherwise = (gs,c)
  where
    l = length $ show k
    cSub = min (gs Map.! l) c

subCount :: IntMap Int -> Int -> Int -> IntMap Int
subCount count k i = Map.update (\x -> Just (x - i)) k count

kill0 :: IntMap Int -> IntMap Int
kill0 = Map.filter (/=0)
-- 1: no change
-- x: 1:1
-- n*x: 1:n 2:1

domainDiff (a, b) (x, y)= (Map.difference a x, Map.difference b y)

foldWithSavings :: [Domain -> (Int, Domain)] -> Domain -> ([Int], Domain)
foldWithSavings fs d = Prelude.foldl (\(s,d) f -> let (s',d') = f d in
      -- traceShow (s',domainDiff d d')
      (s':s,d')) ([],d) fs

-- 1. cancellate all matched: cost 0
cancellateMatched :: Domain -> (Int, Domain)
cancellateMatched (xs, ys) = (savings, (xms, yms))
  where common = Map.intersectionWith min xs ys
        xms = kill0 $ Map.unionWith (-) xs common
        yms = kill0 $ Map.unionWith (-) ys common
        savings = sum $ Map.elems $ Map.mapWithKey computeSave common
        computeSave k v
          | k == 1 = 0
          | k < 10 = 2 * v
          | otherwise = 4 * v

-- 2. match the n to n*x digit: cost 1(saving 2)
matchN :: Domain -> (Int, Domain)
matchN xs =  (savings1 + savings2, nnxs)
  where
    (savings1, nxs) = matchN' xs
    (savings2, nnxs) =  matchN' nxs
matchN' :: Domain -> (Int, Domain)
matchN' (xs, ys) = (savings, (nxs, nys))
  where gs = Map.mapKeysWith (+) (length.show) $ Map.filterWithKey (\k _ -> k > 1 && k < 10) xs
        -- sub if k have the same length as in gs
        (resGs, nys) = (id *** kill0) $ Map.mapAccumWithKey subValue gs ys
        nxs =  kill0 $ unionWith (const) resGs xs
        savings = sum $ Map.elems $ Map.map (2*) (differenceWith (\x y -> Just $ x - y) gs resGs)

-- 3. match n*x to n*y : cost 2(saving 2)
matchNN :: Domain -> (Int, Domain)
matchNN (xs, ys) = (savings, (nxs, nys))
  where

        xls =  Map.mapKeysWith (+) (length . show)$ Map.filterWithKey (\k _ -> k > 1)  xs
        yls =  Map.mapKeysWith (+) (length . show)$ Map.filterWithKey (\k _ -> k > 1)  ys
        common = Map.intersectionWith min xls yls
        nxs = kill0 . snd $ Map.mapAccumWithKey subValue common xs
        nys = kill0 . snd $ Map.mapAccumWithKey subValue common ys
        savings = sum $ Map.elems $ Map.map (2*) common

cost :: IntMap Int -> Int
cost = sum . Map.elems . Map.mapWithKey computeCost
  where computeCost k v
            | k == 1 = 0
            | length (show k) == 1 = 1 * v
            | otherwise = 2 * v

-- (saving none)
-- the following all goes down to 1
-- 4. match the 1 to x: cost 1
-- 5. match 1 to n*x: cost 2
-- 6. match m to n*y : cost 3
-- 7. match m*x to n*y : cost 4
solve :: Solver
solve xs =
  -- traceShow (rest, totalCost, savings)$
  print (totalCost - sum savings)
  where
    (savings, rest) = foldWithSavings [cancellateMatched, matchNN, matchN] xs
    totalCost = cost (uncurry (unionWith (+)) xs)

main :: IO ()
main = do
  [n] <- readChar8
  sequence_ =<< (replicateM n $ solve <$> parse)

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when, liftM3)
import Data.Char (digitToInt, toLower)
import Data.Tuple
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort, intercalate)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.IntMap as Map
import Data.IntMap
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), find, sequenceA_, foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import Control.Monad.Trans.Class
import Control.Exception (assert)
import Data.String

-- type IMap = Set (Int, Int)
type Domain = (IntMap Int, IntMap Int)
type Solver  = Domain -> IO ()

readChar8 :: IO [Int]
readChar8 = fmap (fst . fromJust) . fmap C.readInt . C.words <$> fromString <$> getLine

parse :: IO Domain
parse = do
  [n] <- readChar8
  xs <- readChar8
  ys <- readChar8
  return (toCount xs, toCount ys)

enumerate :: [a] -> [(Int, a)]
enumerate xs = zip [1..length xs] xs

toCount :: [Int] -> IntMap Int
toCount xs = Map.fromListWith (+) (zip xs $ cycle [1])

-- sub if k have the same length as in gs
subValue :: IntMap Int -> Int -> Int -> (IntMap Int, Int)
subValue gs k c
  | l `Map.member` gs = (subCount gs l cSub, c - cSub)
  | otherwise = (gs,c)
  where
    l = length $ show k
    cSub = min (gs Map.! l) c

subCount :: IntMap Int -> Int -> Int -> IntMap Int
subCount count k i = Map.update (\x -> Just (x - i)) k count

kill0 :: IntMap Int -> IntMap Int
kill0 = Map.filter (/=0)
-- 1: no change
-- x: 1:1
-- n*x: 1:n 2:1

domainDiff (a, b) (x, y)= (Map.difference a x, Map.difference b y)

foldWithSavings :: [Domain -> (Int, Domain)] -> Domain -> ([Int], Domain)
foldWithSavings fs d = Prelude.foldl (\(s,d) f -> let (s',d') = f d in
      -- traceShow (s',domainDiff d d')
      (s':s,d')) ([],d) fs

-- 1. cancellate all matched: cost 0
cancellateMatched :: Domain -> (Int, Domain)
cancellateMatched (xs, ys) = (savings, (xms, yms))
  where common = Map.intersectionWith min xs ys
        xms = kill0 $ Map.unionWith (-) xs common
        yms = kill0 $ Map.unionWith (-) ys common
        savings = sum $ Map.elems $ Map.mapWithKey computeSave common
        computeSave k v
          | k == 1 = 0
          | k < 10 = 2 * v
          | otherwise = 4 * v

-- 2. match the n to n*x digit: cost 1(saving 2)
matchN :: Domain -> (Int, Domain)
matchN xs =  (savings1 + savings2, nnxs)
  where
    (savings1, nxs) = matchN' xs
    (savings2, nnxs) =  matchN' nxs
matchN' :: Domain -> (Int, Domain)
matchN' (xs, ys) = (savings, (nxs, nys))
  where gs = Map.mapKeysWith (+) (length.show) $ Map.filterWithKey (\k _ -> k > 1 && k < 10) xs
        -- sub if k have the same length as in gs
        (resGs, nys) = (id *** kill0) $ Map.mapAccumWithKey subValue gs ys
        nxs =  kill0 $ unionWith (const) resGs xs
        savings = sum $ Map.elems $ Map.map (2*) (differenceWith (\x y -> Just $ x - y) gs resGs)

-- 3. match n*x to n*y : cost 2(saving 2)
matchNN :: Domain -> (Int, Domain)
matchNN (xs, ys) = (savings, (nxs, nys))
  where
        xls = Map.filterWithKey (\k _ -> k > 1) $ Map.mapKeysWith (+) (length . show) xs
        yls = Map.filterWithKey (\k _ -> k > 1) $ Map.mapKeysWith (+) (length . show) ys
        common = Map.intersectionWith min xls yls
        nxs = kill0 . snd $ Map.mapAccumWithKey subValue common xs
        nys = kill0 . snd $ Map.mapAccumWithKey subValue common ys
        savings = sum $ Map.elems $ Map.map (2*) common

cost :: IntMap Int -> Int
cost = sum . Map.elems . Map.mapWithKey computeCost
  where computeCost k v
            | k == 1 = 0
            | length (show k) == 1 = 1 * v
            | otherwise = 2 * v

-- (saving none)
-- the following all goes down to 1
-- 4. match the 1 to x: cost 1
-- 5. match 1 to n*x: cost 2
-- 6. match m to n*y : cost 3
-- 7. match m*x to n*y : cost 4
solve :: Solver
solve xs =
  -- traceShow (rest, totalCost, savings)$
  print (totalCost - sum savings)
  where
    (savings, rest) = foldWithSavings [cancellateMatched, matchNN, matchN] xs
    totalCost = cost (uncurry (unionWith (+)) xs)

main :: IO ()
main = do
  [n] <- readChar8
  sequence_ =<< (replicateM n $ solve <$> parse)

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when, liftM3)
import Data.Char (digitToInt, toLower)
import Data.Tuple
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort, intercalate)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.IntMap as Map
import Data.IntMap
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), find, sequenceA_, foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import Control.Monad.Trans.Class
import Control.Exception (assert)
import Data.String

-- type IMap = Set (Int, Int)
type Domain = (IntMap Int, IntMap Int)
type Solver  = Domain -> IO ()

readChar8 :: IO [Int]
readChar8 = fmap (fst . fromJust) . fmap C.readInt . C.words <$> fromString <$> getLine

parse :: IO Domain
parse = do
  [n] <- readChar8
  xs <- readChar8
  ys <- readChar8
  return (toCount xs, toCount ys)

enumerate :: [a] -> [(Int, a)]
enumerate xs = zip [1..length xs] xs

toCount :: [Int] -> IntMap Int
toCount xs = Map.fromListWith (+) (zip xs $ cycle [1])

-- sub if k have the same length as in gs
subValue :: IntMap Int -> Int -> Int -> (IntMap Int, Int)
subValue gs k c
  | l `Map.member` gs = (subCount gs l cSub, c - cSub)
  | otherwise = (gs,c)
  where
    l = length $ show k
    cSub = min (gs Map.! l) c

subCount :: IntMap Int -> Int -> Int -> IntMap Int
subCount count k i = Map.update (\x -> Just (x - i)) k count

kill0 :: IntMap Int -> IntMap Int
kill0 = Map.filter (/=0)
-- 1: no change
-- x: 1:1
-- n*x: 1:n 2:1

domainDiff (a, b) (x, y)= (Map.difference a x, Map.difference b y)

foldWithSavings :: [Domain -> (Int, Domain)] -> Domain -> ([Int], Domain)
foldWithSavings fs d = Prelude.foldl (\(s,d) f -> let (s',d') = f d in
      -- traceShow (s',domainDiff d d')
      (s':s,d')) ([],d) fs

-- 1. cancellate all matched: cost 0
cancellateMatched :: Domain -> (Int, Domain)
cancellateMatched (xs, ys) = (savings, (xms, yms))
  where common = Map.intersectionWith min xs ys
        xms = kill0 $ Map.unionWith (-) xs common
        yms = kill0 $ Map.unionWith (-) ys common
        savings = sum $ Map.elems $ Map.mapWithKey computeSave common
        computeSave k v
          | k == 1 = 0
          | k < 10 = 2 * v
          | otherwise = 2 * v * (length (show k) - 1)

-- 2. match the n to n*x digit: cost 1(saving 2)
matchN :: Domain -> (Int, Domain)
matchN xs =  (savings1 + savings2, nnxs)
  where
    (savings1, nxs) = matchN' xs
    (savings2, nnxs) =  matchN' nxs
matchN' :: Domain -> (Int, Domain)
matchN' (xs, ys) = (savings, (nxs, nys))
  where gs = Map.mapKeysWith (+) (length.show) $ Map.filterWithKey (\k _ -> k > 1 && k < 10) xs
        -- sub if k have the same length as in gs
        (resGs, nys) = (id *** kill0) $ Map.mapAccumWithKey subValue gs ys
        nxs =  kill0 $ unionWith (const) resGs xs
        savings = sum $ Map.elems $ Map.map (2*) (differenceWith (\x y -> Just $ x - y) gs resGs)

-- 3. match n*x to n*y : cost 2(saving 2)
matchNN :: Domain -> (Int, Domain)
matchNN (xs, ys) = (savings, (nxs, nys))
  where
        xls = Map.filterWithKey (\k _ -> k > 1) $ Map.mapKeysWith (+) (length . show) xs
        yls = Map.filterWithKey (\k _ -> k > 1) $ Map.mapKeysWith (+) (length . show) ys
        common = Map.intersectionWith min xls yls
        nxs = kill0 . snd $ Map.mapAccumWithKey subValue common xs
        nys = kill0 . snd $ Map.mapAccumWithKey subValue common ys
        savings = sum $ Map.elems $ Map.map (2*) common

cost :: IntMap Int -> Int
cost = sum . Map.elems . Map.mapWithKey computeCost
  where computeCost k v
            | k == 1 = 0
            | length (show k) == 1 = 1 * v
            | otherwise = 2 * v

-- (saving none)
-- the following all goes down to 1
-- 4. match the 1 to x: cost 1
-- 5. match 1 to n*x: cost 2
-- 6. match m to n*y : cost 3
-- 7. match m*x to n*y : cost 4
solve :: Solver
solve xs =
  -- traceShow (rest, totalCost, savings)$
  print (totalCost - sum savings)
  where
    (savings, rest) = foldWithSavings [cancellateMatched, matchNN, matchN] xs
    totalCost = cost (uncurry (unionWith (+)) xs)

main :: IO ()
main = do
  [n] <- readChar8
  sequence_ =<< (replicateM n $ solve <$> parse)

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when, liftM3)
import Data.Char (digitToInt, toLower)
import Data.Tuple
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort, intercalate)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.IntMap as Map
import Data.IntMap
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), find, sequenceA_, foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import Control.Monad.Trans.Class
import Control.Exception (assert)
import Data.String

-- type IMap = Set (Int, Int)
type Domain = (IntMap Int, IntMap Int)
type Solver  = Domain -> IO ()

readChar8 :: IO [Int]
readChar8 = fmap (fst . fromJust) . fmap C.readInt . C.words <$> fromString <$> getLine

parse :: IO Domain
parse = do
  [n] <- readChar8
  xs <- readChar8
  ys <- readChar8
  return (toCount xs, toCount ys)

enumerate :: [a] -> [(Int, a)]
enumerate xs = zip [1..length xs] xs

toCount :: [Int] -> IntMap Int
toCount xs = Map.fromListWith (+) (zip xs $ cycle [1])

-- sub if k have the same length as in gs
subValue :: IntMap Int -> Int -> Int -> (IntMap Int, Int)
subValue gs k c
  | l `Map.member` gs = (subCount gs l cSub, c - cSub)
  | otherwise = (gs,c)
  where
    l = length $ show k
    cSub = min (gs Map.! l) c

subCount :: IntMap Int -> Int -> Int -> IntMap Int
subCount count k i = Map.update (\x -> Just (x - i)) k count

kill0 :: IntMap Int -> IntMap Int
kill0 = Map.filter (/=0)
-- 1: no change
-- x: 1:1
-- n*x: 1:n 2:1

domainDiff (a, b) (x, y)= (Map.difference a x, Map.difference b y)

foldWithSavings :: [Domain -> (Int, Domain)] -> Domain -> ([Int], Domain)
foldWithSavings fs d = Prelude.foldl (\(s,d) f -> let (s',d') = f d in
      -- traceShow (s',domainDiff d d')
      (s':s,d')) ([],d) fs

-- 1. cancellate all matched: cost 0
cancellateMatched :: Domain -> (Int, Domain)
cancellateMatched (xs, ys) = (savings, (xms, yms))
  where common = Map.intersectionWith min xs ys
        xms = kill0 $ Map.unionWith (-) xs common
        yms = kill0 $ Map.unionWith (-) ys common
        savings = sum $ Map.elems $ Map.mapWithKey computeSave common
        computeSave k v
          | k == 1 = 0
          | k < 10 = 2 * v
          | otherwise = 2 * v * (length (show k) - 1)

-- 2. match the n to n*x digit: cost 1(saving 2)
matchN :: Domain -> (Int, Domain)
matchN xs =  (savings1 + savings2, nnxs)
  where
    (savings1, nxs) = matchN' xs
    (savings2, nnxs) =  matchN' nxs
matchN' :: Domain -> (Int, Domain)
matchN' (xs, ys) = (savings, (nxs, nys))
  where gs = Map.mapKeysWith (+) (length.show) $ Map.filterWithKey (\k _ -> k > 1 && k < 10) xs
        -- sub if k have the same length as in gs
        (resGs, nys) = (id *** kill0) $ Map.mapAccumWithKey subValue gs ys
        nxs =  kill0 $ unionWith (const) resGs xs
        savings = sum $ Map.elems $ Map.map (2*) (differenceWith (\x y -> Just $ x - y) gs resGs)

-- 3. match n*x to n*y : cost 2(saving 2)
matchNN :: Domain -> (Int, Domain)
matchNN (xs, ys) = (savings, (nxs, nys))
  where
        xls = Map.filterWithKey (\k _ -> k > 1) $ Map.mapKeysWith (+) (length . show) xs
        yls = Map.filterWithKey (\k _ -> k > 1) $ Map.mapKeysWith (+) (length . show) ys
        common = Map.intersectionWith min xls yls
        nxs = kill0 . snd $ Map.mapAccumWithKey subValue common xs
        nys = kill0 . snd $ Map.mapAccumWithKey subValue common ys
        savings = sum $ Map.elems $ Map.map (2*) common

cost :: IntMap Int -> Int
cost = sum . Map.elems . Map.mapWithKey computeCost
  where computeCost k v
            | k == 1 = 0
            | length (show k) == 1 = 1 * v
            | otherwise = 2 * v

-- (saving none)
-- the following all goes down to 1
-- 4. match the 1 to x: cost 1
-- 5. match 1 to n*x: cost 2
-- 6. match m to n*y : cost 3
-- 7. match m*x to n*y : cost 4
solve :: Solver
solve xs =
  -- traceShow (rest, totalCost, savings)$
  print (totalCost - sum savings)
  where
    (savings, rest) = foldWithSavings [cancellateMatched, matchN, matchNN] xs
    totalCost = cost (uncurry (unionWith (+)) xs)

main :: IO ()
main = do
  [n] <- readChar8
  sequence_ =<< (replicateM n $ solve <$> parse)


Little Bolek has found a picture with n mountain peaks painted on it. The n painted peaks are represented by a non-closed polyline, consisting of 2n segments. The segments go through 2n + 1 points with coordinates (1, y1), (2, y2), ..., (2n + 1, y2n + 1), with the i-th segment connecting the point (i, yi) and the point (i + 1, yi + 1). For any even i (2 ≤ i ≤ 2n) the following condition holds: yi - 1 < yi and yi > yi + 1. We shall call a vertex of a polyline with an even x coordinate a mountain peak.   The figure to the left shows the initial picture, the figure to the right shows what the picture looks like after Bolek's actions. The affected peaks are marked red, k = 2.  Bolek fancied a little mischief. He chose exactly k mountain peaks, rubbed out the segments that went through those peaks and increased each peak's height by one (that is, he increased the y coordinate of the corresponding points). Then he painted the missing segments to get a new picture of mountain peaks. Let us denote the points through which the new polyline passes on Bolek's new picture as (1, r1), (2, r2), ..., (2n + 1, r2n + 1).Given Bolek's final picture, restore the initial one.

The first line contains two space-separated integers n and k (1 ≤ k ≤ n ≤ 100). The next line contains 2n + 1 space-separated integers r1, r2, ..., r2n + 1 (0 ≤ ri ≤ 100) — the y coordinates of the polyline vertices on Bolek's picture. It is guaranteed that we can obtain the given picture after performing the described actions on some picture of mountain peaks.

Print 2n + 1 integers y1, y2, ..., y2n + 1 — the y coordinates of the vertices of the polyline on the initial picture. If there are multiple answers, output any one of them.

import List (sort)
import Prelude hiding (reads)

reads :: Read a => IO [a]
reads  =  getLine >>= return . map read . words

solve :: Int -> [Int] -> [Int]
solve 0 as  =  as
solve k (x:y:z:as)
  | y > x + 1 && y > z + 1  =  x : (y-1) : (solve (k-1) (z:as))
  | otherwise  =  x : y : solve k (z:as)

prints :: [Int] -> IO ()
prints []  =  return ()
prints [x]  =  print x
prints (x:xs)  =  putStr (show x ++ " ") >> prints xs

main :: IO ()
main  =  do
    [n, k]  <-  reads
    as  <-  reads
    prints $ solve k as

-- Codeforces 218A

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

import Control.Applicative
import Control.Applicative
import Control.Monad.ST.Safe
import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as BC
import Data.List
import Data.Maybe

main :: IO ()
main = do
    [n, k] <- (map read . words) <$> getLine
    xs <- (map (fst . fromJust . BC.readInt) . BC.words) <$> BC.getContents
    go xs 0 k
  where
    go xs i k | i == k = putStr (intercalate " " (map show xs))
    go (a:b:c:xs) i k = do
        let peak = a + 1 < b && c + 1 < b
        putStr (show a)
        putStr " "
        putStr (show $ if peak then (b - 1) else b)
        putStr " "
        go (c:xs) (if peak then (i + 1) else i) k

import Control.Applicative

main = do
  [_,k] <- map read.words <$> getLine
  vs <- map read.words <$> getLine
  let solve 0 xs = putStrLn.unwords.map show $ xs
      solve rest (x:y:z:xs)
        | x<y-1 && y-1>z = putStr (shows x" ") >> putStr (shows(y-1)" ") >> solve (rest-1) (z:xs)
        | otherwise = putStr (shows x" ") >> putStr (shows y" ") >> solve rest (z:xs)
  solve k vs

import Control.Applicative
import Control.Monad

f :: Int -> [Int] -> [Int]
f 0 xs         = xs
f n (x:y:z:xs) = if p [x,y,z] then x:(y-1):tail else x:y:tail'
  where
  p [a,b,c] = (b-1) > a && (b-1) > c
  tail      = f (n-1) (z:xs)
  tail'     = f n (z:xs)

main = do
  k  <-  head . fmap read . tail . words <$> getLine
  ps <- fmap read . words <$> getLine
  mapM_ (putStr . (++ " ") . show) (f k ps)

import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Char

main :: IO ()
main = do
	line1 <- getLine
	line2 <- getLine
	let
		[n, k] = map (\x -> read x :: Int). words $ line1
		arr = map (\x -> read x :: Int). words $line2
		solve _ [] _ = []
		solve lst aas@(a:b:as) k
		 | k == 0 = aas
		 | a -1> lst && a -1 > b = (a-1):  b : solve (b) as (k-1)
		 | otherwise = a:b : solve b as k
----	print n
--	print k
--	print arr
	mapM_ (\x -> putStr $ show x ++ " ") $ head arr : solve (head arr) (tail arr) k

import Data.List

revertChanges k all@(prev:cur:next:ys)
    | k == 0    = all
    | null ys   = [prev, cur', next]
    | otherwise = [prev, cur'] ++ revertChanges k' (next : ys)
    where (k', cur') = if cur - 1 > prev && cur - 1 > next
                       then (k - 1, cur - 1)
                       else (k, cur)

main = do
    args0 <- getLine
    args1 <- getLine
    let readInt s    = read s :: Int
        readInts s n = map readInt $ take n $ words s
        [n, k]    = readInts args0 2
        ys        = readInts args1 (2 * n + 1)
        result    = revertChanges k ys
    putStrLn $ intercalate " " $ map show result

import List (sort)
import Prelude hiding (reads)

reads :: Read a => IO [a]
reads  =  getLine >>= return . map read . words

solve :: Int -> [Int] -> [Int]
solve 0 as  =  as
solve k (x:y:z:as)
  | y > x + 1 && y > z + 1  =  x : (y-1) : (solve (k-1) (z:as))
  | otherwise  =  solve k (z:as)

prints :: [Int] -> IO ()
prints []  =  return ()
prints [x]  =  print x
prints (x:xs)  =  putStr (show x ++ " ") >> prints xs

main :: IO ()
main  =  do
    [n, k]  <-  reads
    as  <-  reads
    prints $ solve k as

import Control.Applicative
import Control.Monad
import Data.Array.Base
import Data.Array.IO(IOUArray)
import Data.List
import Data.Ord

main = do
  [_,k] <- map read.words <$> getLine
  vs <- map read.words <$> getLine
  let peaks = f vs
       where
         f [x] = []
         f (_:x:xs) = x:f xs
  c <- newArray (0,100) 0 :: IO (IOUArray Int Int)
  forM_ peaks $ \p-> do
    unsafeRead c p >>= unsafeWrite c p . (1+)
  cnts <- unsafeFreeze c :: IO (UArray Int Int)
  let pmax= fst.head.filter ((k<=).snd) $ assocs cnts
      solve 0 xs = putStrLn.unwords.map show $ xs
      solve rest (x:xs)
        | x==pmax = putStr (shows(x-1)" ") >> solve (rest-1) xs
        | otherwise = putStr (shows x" ") >> solve rest xs
  solve k vs

import Control.Applicative
import Control.Monad
import Data.Array.Base
import Data.Array.IO(IOUArray)
import Data.List
import Data.Ord

main = do
  [_,k] <- map read.words <$> getLine
  vs <- map read.words <$> getLine
  let peaks = f vs
       where
         f [x] = []
         f (_:x:xs) = x:f xs
  c <- newArray (0,100) 0 :: IO (IOUArray Int Int)
  forM_ peaks $ \p-> do
    unsafeRead c p >>= unsafeWrite c p . (1+)
  cnts <- unsafeFreeze c :: IO (UArray Int Int)
  let pmax= fst.head.filter ((k<=).snd) $ assocs cnts
      solve 0 xs = putStrLn.unwords.map show $ xs
      solve rest (x:y:xs)
        | y==pmax = putStr (shows x" ") >> putStr (shows(y-1)" ") >> solve (rest-1) xs
        | otherwise = putStr (shows x" ") >>  putStr (shows y" ") >> solve rest xs
  solve k vs

import Control.Applicative

main = do
  [_,k] <- map read.words <$> getLine
  vs <- map read.words <$> getLine
  let solve 0 xs = putStrLn.unwords.map show $ xs
      solve rest (x:y:xs) = putStr (shows x" ") >> putStr (shows(y-1)" ") >> solve (rest-1) xs
  solve k vs

import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Char

main :: IO ()
main = do
	line1 <- getLine
	line2 <- getLine
	let
		[n, k] = map (\x -> read x :: Int). words $ line1
		arr = map (\x -> read x :: Int). words $line2
		solve _ [] _ = []
		solve lst (a:b:as) k
		 | k <= 0 = (a:b:as)
		 | a > lst && a > b = (a-1):  b : solve (b) as (k-1)
		 | otherwise = a:b : solve b as k
	print n
	print k
	print arr
	print $ head arr : solve (head arr) (tail arr) k

import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Char

main :: IO ()
main = do
	line1 <- getLine
	line2 <- getLine
	let
		[n, k] = map (\x -> read x :: Int). words $ line1
		arr = map (\x -> read x :: Int). words $line2
		solve _ [] _ = []
		solve lst (a:b:as) k
		 | k <= 0 = (a:b:as)
		 | a > lst && a > b = (a-1):  b : solve (b) as (k-1)
		 | otherwise = a:b : solve b as k
----	print n
--	print k
--	print arr
	mapM_ (\x -> putStr $ show x ++ " ") $ head arr : solve (head arr) (tail arr) k

import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Char

main :: IO ()
main = do
	line1 <- getLine
	line2 <- getLine
	let
		[n, k] = map (\x -> read x :: Int). words $ line1
		arr = map (\x -> read x :: Int). words $line2
		solve _ [] _ = []
		solve lst aas@(a:b:as) k
		 | k == 0 = aas
		 | a > lst && a > b = (a-1):  b : solve (b) as (k-1)
		 | otherwise = a:b : solve b as k
----	print n
--	print k
--	print arr
	mapM_ (\x -> putStr $ show x ++ " ") $ head arr : solve (head arr) (tail arr) k

import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Char

main :: IO ()
main = do
	line1 <- getLine
	line2 <- getLine
	let
		[n, k] = map (\x -> read x :: Int). words $ line1
		arr = map (\x -> read x :: Int). words $line2
		solve _ [] _ = []
		solve lst (a:b:as) k
		 | k <= 0 = (a:b:as)
		 | a > lst && a > b = (a-1):  b : solve (b) as (k-1)
		 | otherwise = a:b : solve b as k
	print n
	print k
	print arr
	mapM_ (\x -> putStr $ show x ++ " ") $ head arr : solve (head arr) (tail arr) k


The only difference between easy and hard versions is constraints.Now elections are held in Berland and you want to win them. More precisely, you want everyone to vote for you.There are $$$n$$$ voters, and two ways to convince each of them to vote for you. The first way to convince the $$$i$$$-th voter is to pay him $$$p_i$$$ coins. The second way is to make $$$m_i$$$ other voters vote for you, and the $$$i$$$-th voter will vote for free.Moreover, the process of such voting takes place in several steps. For example, if there are five voters with $$$m_1 = 1$$$, $$$m_2 = 2$$$, $$$m_3 = 2$$$, $$$m_4 = 4$$$, $$$m_5 = 5$$$, then you can buy the vote of the fifth voter, and eventually everyone will vote for you. Set of people voting for you will change as follows: $$${5} \rightarrow {1, 5} \rightarrow {1, 2, 3, 5} \rightarrow {1, 2, 3, 4, 5}$$$.Calculate the minimum number of coins you have to spend so that everyone votes for you.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 5000$$$) — the number of test cases. The first line of each test case contains one integer $$$n$$$ ($$$1 \le n \le 5000$$$) — the number of voters. The next $$$n$$$ lines contains the description of voters. $$$i$$$-th line contains two integers $$$m_i$$$ and $$$p_i$$$ ($$$1 \le p_i \le 10^9, 0 \le m_i < n$$$). It is guaranteed that the sum of all $$$n$$$ over all test cases does not exceed $$$5000$$$.

For each test case print one integer — the minimum number of coins you have to spend so that everyone votes for you.

NoteIn the first test case you have to buy vote of the third voter. Then the set of people voting for you will change as follows: $$${3} \rightarrow {1, 3} \rightarrow {1, 2, 3}$$$.In the second example you don't need to buy votes. The set of people voting for you will change as follows: $$${1} \rightarrow {1, 3, 5} \rightarrow {1, 2, 3, 5} \rightarrow {1, 2, 3, 5, 6, 7} \rightarrow {1, 2, 3, 4, 5, 6, 7}$$$.In the third test case you have to buy votes of the second and the fifth voters. Then the set of people voting for you will change as follows: $$${2, 5} \rightarrow {1, 2, 3, 4, 5} \rightarrow {1, 2, 3, 4, 5, 6}$$$.

{-# LANGUAGE Strict #-}
{-# OPTIONS_GHC -O2 #-}
-- Data.MultiSet not available on Codeforces...
module Main where

import qualified Data.ByteString.Char8 as BS
import Data.List
-- import Data.MultiSet (MultiSet)
-- import qualified Data.MultiSet as MultiSet
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
-- import Debug.Trace

main :: IO ()
main = BS.interact (BS.unlines . runRaw . BS.words)

bs2int :: BS.ByteString -> Integer
bs2int = fst . Maybe.fromJust . BS.readInteger

int2bs :: Integer -> BS.ByteString
int2bs = BS.pack . show

runRaw :: [BS.ByteString] -> [BS.ByteString]
runRaw str_data = map int2bs $ run $ map bs2int str_data

run :: [Integer] -> [Integer]
run (nb_testcases:testcase_data) = executeTestcases nb_testcases testcase_data

executeTestcases :: Integer -> [Integer] -> [Integer]
executeTestcases 0 _ = []
executeTestcases remaining_testcases testcase_data =
  let (result, remaining_testcase_data) = executeTestcase testcase_data
   in result :
      executeTestcases (remaining_testcases - 1) remaining_testcase_data

executeTestcase :: [Integer] -> (Integer, [Integer])
executeTestcase (n:remaining_data) =
  let (voter_config_data, other_remaining_data) = splitAt (fromIntegral n * 2) remaining_data
      voter_configs = extractPairs voter_config_data
      sorted_voter_configs = map (\pairs -> (fst $ head pairs, map snd pairs)) $ groupBy (\a b -> fst a == fst b) $ sortBy (\a b -> fst b `compare` fst a) voter_configs
    --   _ = traceId $ "sorted voter configs: " ++ show sorted_voter_configs
      result = bribeVoters sorted_voter_configs n createEmptyMultiSet
   in (result, other_remaining_data)

bribeVoters :: [(Integer, [Integer])] -> Integer -> FMultiSet -> Integer
bribeVoters [] _ _ = 0
bribeVoters ((m,prices):remaining_voter_prices) nb_remaining_voters available_voter_prices =
    let nb_voters_in_group = fromIntegral $ length prices
        nb_voters_with_smaller_m = nb_remaining_voters - nb_voters_in_group
        nb_voters_to_bribe = max 0 $ m - nb_voters_with_smaller_m

        group_prices_set = createFMultiSetFromList prices
        union_available_prices_set = unionFMultiSet available_voter_prices group_prices_set
        -- _ = traceId $ "available prices to bribe " ++ show nb_voters_to_bribe ++ " voters: " ++ show union_available_prices_set
        (cost_to_bribe, updated_available_prices_set) = findCheapestBribableVoters nb_voters_to_bribe union_available_prices_set
        -- _ = traceId $ "cost to bribe: " ++ show cost_to_bribe
    in cost_to_bribe + bribeVoters remaining_voter_prices (nb_voters_with_smaller_m + nb_voters_to_bribe) updated_available_prices_set

findCheapestBribableVoters :: Integer -> FMultiSet -> (Integer, FMultiSet)
findCheapestBribableVoters 0 available_prices = (0, available_prices)
findCheapestBribableVoters n available_prices =
    let (cheapest, updated_available_prices) = deleteFindMinFMultiSet available_prices
        (remaining_cost, final_updated_available_prices) = findCheapestBribableVoters (n-1) updated_available_prices
    in (remaining_cost + cheapest, final_updated_available_prices)

extractPairs :: [Integer] -> [(Integer, Integer)]
extractPairs [] = []
extractPairs (a:b:remainder) = (a, b) : extractPairs remainder

type FMultiSet = Map Integer Integer

createEmptyMultiSet :: FMultiSet
createEmptyMultiSet = Map.empty

createFMultiSetFromList :: [Integer] -> FMultiSet
createFMultiSetFromList list =
    let sortedList = sort list
        groupedPrices = map (\prices -> (head prices, fromIntegral $ length prices)) $ group sortedList
    in Map.fromList groupedPrices

unionFMultiSet :: FMultiSet -> FMultiSet -> FMultiSet
unionFMultiSet = Map.unionWith (+)

deleteFindMinFMultiSet :: FMultiSet -> (Integer, FMultiSet)
deleteFindMinFMultiSet map =
    let (price, frequency) = Map.findMin map
        updated_map =
            if frequency == 1
                then Map.delete price map
                else Map.insert price (frequency - 1) map
    in (price, updated_map)


You are given $$$n$$$ points with integer coordinates on a coordinate axis $$$OX$$$. The coordinate of the $$$i$$$-th point is $$$x_i$$$. All points' coordinates are distinct and given in strictly increasing order.For each point $$$i$$$, you can do the following operation no more than once: take this point and move it by $$$1$$$ to the left or to the right (i..e., you can change its coordinate $$$x_i$$$ to $$$x_i - 1$$$ or to $$$x_i + 1$$$). In other words, for each point, you choose (separately) its new coordinate. For the $$$i$$$-th point, it can be either $$$x_i - 1$$$, $$$x_i$$$ or $$$x_i + 1$$$.Your task is to determine if you can move some points as described above in such a way that the new set of points forms a consecutive segment of integers, i. e. for some integer $$$l$$$ the coordinates of points should be equal to $$$l, l + 1, \ldots, l + n - 1$$$.Note that the resulting points should have distinct coordinates.You have to answer $$$t$$$ independent test cases.

The first line of the input contains one integer $$$t$$$ ($$$1 \le t \le 2 \cdot 10^4$$$) — the number of test cases. Then $$$t$$$ test cases follow. The first line of the test case contains one integer $$$n$$$ ($$$1 \le n \le 2 \cdot 10^5$$$) — the number of points in the set $$$x$$$. The second line of the test case contains $$$n$$$ integers $$$x_1 < x_2 < \ldots < x_n$$$ ($$$1 \le x_i \le 10^6$$$), where $$$x_i$$$ is the coordinate of the $$$i$$$-th point. It is guaranteed that the points are given in strictly increasing order (this also means that all coordinates are distinct). It is also guaranteed that the sum of $$$n$$$ does not exceed $$$2 \cdot 10^5$$$ ($$$\sum n \le 2 \cdot 10^5$$$).

For each test case, print the answer — if the set of points from the test case can be moved to form a consecutive segment of integers, print YES, otherwise print NO.

showB x = if x then "YES" else "NO"

chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf i xs = take i xs : chunksOf i (drop i xs)

solve :: [Int] -> Bool
solve x = let n = length x in (last x - head x) <= n+1

receive :: [String] -> [Int]
receive = map read . words . last

main = interact $ unlines . map (showB . solve . receive) . chunksOf 2 . tail . lines

-- {-# OPTIONS_GHC -O2 #-}

import qualified Data.Text as T
import qualified Data.Text.IO as TI

readt = read . T.unpack
showt = T.pack . showB

showB x = if x then "YES" else "NO"

chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf i xs = take i xs : chunksOf i (drop i xs)

solve :: [Int] -> Bool
solve x = let n = length x in (last x - head x) <= n+1

receive :: [T.Text] -> [Int]
receive = map readt . T.words . last

main = TI.interact $ T.unlines . map (showt . solve . receive) . chunksOf 2 . tail . T.lines

chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf i xs = take i xs : chunksOf i (drop i xs)

showArr :: Show a => [a] -> String
showArr = concatMap (\x -> show x ++ " ")

toArr :: Read a => String -> [a]
toArr = map read . words

getPair :: String -> (Int, Int)
getPair s = case toArr s of
              [x, y] -> (x, y)
              _      -> error "getPair failed"

type InType  = [Int]
type OutType = Bool

solve :: InType -> OutType
solve [] = True
solve (x : t) = go x t || go (x - 1) t || go (x + 1) t
  where go _ [] = True
        go was (x' : t')
          | abs (x' - was) <= 2 = go (was + 1) t'
          | otherwise = False

receive :: [String] -> InType
receive [_, s] = toArr s
receive _      = error "input error"

main :: IO ()
main = interact $ unlines . map (showB . solve . receive) . chunksOf 2 . tail . lines
  where showB True  = "YES"
        showB False = "NO"


God's Blessing on This PermutationForces!A Random PebbleYou are given a permutation $$$p_1,p_2,\ldots,p_n$$$ of length $$$n$$$ and a positive integer $$$k \le n$$$. In one operation you can choose two indices $$$i$$$ and $$$j$$$ ($$$1 \le i < j \le n$$$) and swap $$$p_i$$$ with $$$p_j$$$.Find the minimum number of operations needed to make the sum $$$p_1 + p_2 + \ldots + p_k$$$ as small as possible.A permutation is an array consisting of $$$n$$$ distinct integers from $$$1$$$ to $$$n$$$ in arbitrary order. For example, $$$[2,3,1,5,4]$$$ is a permutation, but $$$[1,2,2]$$$ is not a permutation ($$$2$$$ appears twice in the array) and $$$[1,3,4]$$$ is also not a permutation ($$$n=3$$$ but there is $$$4$$$ in the array).

Each test contains multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \le t \le 100$$$). Description of the test cases follows. The first line of each test case contains two integers $$$n$$$ and $$$k$$$ ($$$1 \le k \le n \le 100$$$). The second line of each test case contains $$$n$$$ integers $$$p_1,p_2,\ldots,p_n$$$ ($$$1 \le p_i \le n$$$). It is guaranteed that the given numbers form a permutation of length $$$n$$$.

For each test case print one integer — the minimum number of operations needed to make the sum $$$p_1 + p_2 + \ldots + p_k$$$ as small as possible.

NoteIn the first test case, the value of $$$p_1 + p_2 + \ldots + p_k$$$ is initially equal to $$$2$$$, but the smallest possible value is $$$1$$$. You can achieve it by swapping $$$p_1$$$ with $$$p_3$$$, resulting in the permutation $$$[1, 3, 2]$$$.In the second test case, the sum is already as small as possible, so the answer is $$$0$$$.

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

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

{-# options_ghc -O3                              #-}

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

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

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

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

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

solve (_n,k,xs) = length . filter (>k) . take k $ xs

module Main where
import Control.Monad

solve::Int->Int->Int
solve k x
    |x<=k=0
    |otherwise=1

main = do
  line<-getLine
  let nTerm=read line::Int
  replicateM_ nTerm$do
    line<-getLine
    let (n:k:_)=map read (words line)::[Int]
    line<-getLine
    let nlist=map read (words line)::[Int]
    print$sum(map (solve k) (take k nlist))