You are given a square grid with $$$n$$$ rows and $$$n$$$ columns. Each cell contains either $$$0$$$ or $$$1$$$. In an operation, you can select a cell of the grid and flip it (from $$$0 \to 1$$$ or $$$1 \to 0$$$). Find the minimum number of operations you need to obtain a square that remains the same when rotated $$$0^{\circ}$$$, $$$90^{\circ}$$$, $$$180^{\circ}$$$ and $$$270^{\circ}$$$.The picture below shows an example of all rotations of a grid.

The first line contains a single integer $$$t$$$ ($$$1 \leq t \leq 100$$$) — the number of test cases. The first line of each test case contains a single integer $$$n$$$ ($$$1 \leq n \leq 100$$$) — the size of the grid. Then $$$n$$$ lines follow, each with $$$n$$$ characters $$$a_{i,j}$$$ ($$$0 \leq a_{i,j} \leq 1$$$) — the number written in each cell.

For each test case output a single integer  — the minimum number of operations needed to make the square look the same rotated $$$0^{\circ}$$$, $$$90^{\circ}$$$, $$$180^{\circ}$$$ and $$$270^{\circ}$$$.

NoteIn the first test case, we can perform one operations to make the grid $$$\begin{matrix}0 & 1 & 0\\ 1 & 1 & \color{red}{1}\\ 0 & 1 & 0\end{matrix}$$$. Now, all rotations of the square are the same.In the second test case, all rotations of the square are already the same, so we don't need any flips.

import Control.Monad
import Data.List
import qualified Data.Set as Set

check :: String -> String -> Set.Set String -> Bool
check "" suff set = False
check pref suff set =
    if suff /= "" && Set.member pref set && Set.member suff set
    then True
    else check (init pref) ((last pref) : suff) set

solve :: [String] -> Int -> Int -> Int -> Int
solve strs n i j
    | i == n `div` 2 = 0
    | j == (n + 1) `div` 2 =
        solve strs n (i+1) 0
    | otherwise =
        (min cost (4 - cost)) + solve strs n i (j+1)
        where
            ri = n - i - 1
            rj = n - j - 1
            cost = sum $ map fromEnum $ map (\x -> x == '1')
                [strs !! i !! j, strs !! j !! ri, strs !! rj !! i, strs !! ri !! rj]

testcase 0 = return ()
testcase t = do
    n <- readLn :: IO Int
    strs <- forM [1..n] (\x -> getLine)
    putStrLn $ show $ solve strs n 0 0
    testcase (t - 1)

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

import Control.Monad
import Data.List
import qualified Data.Set as Set

check :: String -> String -> Set.Set String -> Bool
check "" suff set = False
check pref suff set =
    if suff /= "" && Set.member pref set && Set.member suff set
    then True
    else check (init pref) ((last pref) : suff) set

solve :: [String] -> Int -> Int -> Int -> Int
solve strs n i j
    | i == n `div` 2 = 0
    | j == (n + 1) `div` 2 =
        solve strs n (i+1) 0
    | otherwise =
        (min cost (4 - cost)) + solve strs n i (j+1)
            where
                ri = n - i - 1
                rj = n - j - 1
                cost = sum $ map (\x -> if x == '1' then 1 else 0) (
                    [strs !! i !! j, strs !! j !! ri, strs !! rj !! i, strs !! ri !! rj])

testcase 0 = return ()
testcase t = do
    n <- readLn :: IO Int
    strs <- forM [1..n] (\x -> getLine)
    putStrLn $ show $ solve strs n 0 0
    testcase (t - 1)

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

import Control.Monad
import Data.List
import qualified Data.Set as Set

check :: String -> String -> Set.Set String -> Bool
check "" suff set = False
check pref suff set =
    if suff /= "" && Set.member pref set && Set.member suff set
    then True
    else check (init pref) ((last pref) : suff) set

solve :: [String] -> Int -> Int -> Int -> Int
solve strs n i j =
    if i == n `div` 2
    then 0
    else if j == (n + 1) `div` 2
        then solve strs n (i+1) 0
        else (min cost (4 - cost)) + solve strs n i (j+1)
            where
                ri = n - i - 1
                rj = n - j - 1
                cost = sum $ map (\x -> if x == '1' then 1 else 0) (
                    [strs !! i !! j, strs !! j !! ri, strs !! rj !! i, strs !! ri !! rj])

testcase 0 = return ()
testcase t = do
    n <- readLn :: IO Int
    strs <- forM [1..n] (\x -> getLine)
    putStrLn $ show $ solve strs n 0 0
    testcase (t - 1)

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

import Control.Monad
import Data.List
import Data.Char
import qualified Data.ByteString.Char8 as BS

skipWhitespace :: BS.ByteString -> BS.ByteString
skipWhitespace = BS.dropWhile (`elem` " \r\n\t")

readInts :: BS.ByteString -> [Int]
readInts line = case BS.readInt line of Just (x, t) -> x : (readInts (skipWhitespace t))
                                        Nothing -> []
readInt :: BS.ByteString -> Int
readInt line = let [x] = readInts line in x

count :: Eq a => a -> [a] -> Int
count x xs = length (filter (==x) xs)

unique :: Ord a => [a] -> [a]
unique = map head . group . sort

solve n lines = sum $ map (impl . map get) $ unique $ map unique $ indexPairList
    where half = (n - 1) `div` 2
          rot (i, j) = (n - 1 - j, i)
          get (i, j) = (BS.index (lines !! i) j)
          indexPairList = [[(i, j), rot (i, j), (rot . rot) (i, j), (rot . rot . rot) (i, j)] | i <- [0 .. half], j <- [0 .. half]]
          impl xs = min (count '1' xs) (count '0' xs)

testCaseMain :: Int -> IO ()
testCaseMain _ = do n <- readInt <$> BS.getLine
                    lines <- forM [1 .. n] (\_ -> BS.getLine)
                    print (solve n lines)

main :: IO ()
main = do t <- readInt <$> BS.getLine
          forM_ [1 .. t] testCaseMain

{-# LANGUAGE LambdaCase #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe, catMaybes)
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, nub, intercalate)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Data.Function (on)
-- import System.Random
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Debug.Trace
import Data.Bool (bool)
import Data.Foldable (foldlM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.String (fromString)
import Data.Bits (shift)
import Data.Binary (encode, decode)

-- road map in reverse, and the number of cities, init pen state
type Domain = [[Int]]
type CoDomain = Int
type Solver  = Domain -> CoDomain

toInt :: Char -> Int
toInt '1' = 1
toInt '0' = 0

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

printAns :: CoDomain -> IO ()
printAns xs = putStrLn $ show xs

parse :: IO Domain
parse = do
  [n] <- readChar8
  xs <- replicateM n $ (fmap toInt <$> getLine)
  return xs

rotate :: Int -> (Int, Int) -> (Int, Int)
rotate n (a, b) = (n-1-b, a)

sym :: Int -> (Int, Int) -> [(Int, Int)]
sym = (take 4 .) . iterate . rotate

get :: [[Int]] -> (Int,Int) -> Int
get xs (x,y) = xs !! x !! y

cal :: [[Int]] -> [(Int, Int)] -> Int
cal xs coords = min s (4 - s)
  where n = length xs
        s = sum $ get xs <$> coords

solve :: Solver
solve xs =  sum (cal xs <$> coords) `div` 4
  where n = length xs
        indices = [0..n-1]
        coords = sym n  <$> liftM2 (,) indices indices

main :: IO ()
main = do
  [n] <- readChar8
  replicateM_ n $ printAns =<< solve <$> parse
  return ()

import           Data.List
import qualified Data.Char as DC
import qualified Data.Set as Set
import Control.Monad (replicateM)

inverseTpl :: Int -> (Int, Int, Char) -> (Int, Int, Char)

inverseTpl n (a, b, c) = (b, n - a - 1, c)

trd (_, _, z) = z
zv c = if c then 1 else 0

sumOtherF :: Int -> Set.Set (Int, Int, Char) -> (Int, Int, Char) -> Int
sumOtherF n set (a, b, c) = sumOther n set (a, b, '1')

sumOther :: Int -> Set.Set (Int, Int, Char) -> (Int, Int, Char) -> Int
sumOther n set tpl =
    let i1 = inverseTpl n
        i2 = i1 . i1
        i3 = i1 . i2
        t1 = Set.member (i1 tpl) set
        t2 = Set.member (i2 tpl) set
        t3 = Set.member (i3 tpl) set
    in (zv t1) + (zv t2) + (zv t3)

shouldChange :: Int -> Set.Set (Int, Int, Char) -> (Int, Int, Char) -> Bool
shouldChange n set (a, b, c)
    | c == '0' = sumOtherF n set (a, b, c) >= 2
    | otherwise = sumOtherF n set (a, b, c) == 0

solveCase :: IO ()
solveCase = do
    n <- fmap (read :: String -> Int) getLine
    strs <- replicateM n getLine
    let prikols = concat $ map (\ilst -> map (\tp2 -> ((fst ilst), (fst tp2), (snd tp2))) $ zip [0..n-1] (snd ilst)) $ zip [0..n-1] strs
    let setik = Set.fromList prikols
    let res = filter (shouldChange n setik) prikols
    putStrLn $ show $ length res

solve :: Int -> IO ()
solve 0 = do
    return ()
solve cases_left = do
    solveCase
    solve $ cases_left - 1

main = do
    s_testcases <- getLine
    solve $ (read s_testcases :: Int)


You are given a sequence $$$a$$$ of length $$$n$$$ consisting of $$$0$$$s and $$$1$$$s.You can perform the following operation on this sequence:   Pick an index $$$i$$$ from $$$1$$$ to $$$n-2$$$ (inclusive).  Change all of $$$a_{i}$$$, $$$a_{i+1}$$$, $$$a_{i+2}$$$ to $$$a_{i} \oplus a_{i+1} \oplus a_{i+2}$$$ simultaneously, where $$$\oplus$$$ denotes the bitwise XOR operation  Find a sequence of at most $$$n$$$ operations that changes all elements of $$$a$$$ to $$$0$$$s or report that it's impossible.We can prove that if there exists a sequence of operations of any length that changes all elements of $$$a$$$ to $$$0$$$s, then there is also such a sequence of length not greater than $$$n$$$.

Each test contains multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \le t \le 10^4$$$). The first line of each test case contains a single integer $$$n$$$ ($$$3 \le n \le 2\cdot10^5$$$) — the length of $$$a$$$. The second line of each test case contains $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$ ($$$a_i = 0$$$ or $$$a_i = 1$$$) — elements of $$$a$$$. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$2\cdot10^5$$$.

For each test case, do the following:    if there is no way of making all the elements of $$$a$$$ equal to $$$0$$$ after performing the above operation some number of times, print "NO".  otherwise, in the first line print "YES", in the second line print $$$k$$$ ($$$0 \le k \le n$$$) — the number of operations that you want to perform on $$$a$$$, and in the third line print a sequence $$$b_1, b_2, \dots, b_k$$$ ($$$1 \le b_i \le n - 2$$$) — the indices on which the operation should be applied.  If there are multiple solutions, you may print any.

NoteIn the first example, the sequence contains only $$$0$$$s so we don't need to change anything.In the second example, we can transform $$$[1, 1, 1, 1, 0]$$$ to $$$[1, 1, 0, 0, 0]$$$ and then to $$$[0, 0, 0, 0, 0]$$$ by performing the operation on the third element of $$$a$$$ and then on the first element of $$$a$$$.In the third example, no matter whether we first perform the operation on the first or on the second element of $$$a$$$ we will get $$$[1, 1, 1, 1]$$$, which cannot be transformed to $$$[0, 0, 0, 0]$$$.

import qualified Data.ByteString.Lazy.Char8 as P
import Data.ByteString.Builder
import qualified Data.ByteString.Builder.Prim as Prim
import System.IO
import Control.Monad.Trans.State

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

evens :: [a] -> [a]
evens [] = []
evens (x0 : []) = x0 : []
evens (x0 : _x1 : xs) = x0 : evens xs

solve :: Int -> [Int] -> Maybe [Int]
solve n aLi = let
  a :: UArray Int Int
  a = listArray (1, n) aLi
  axor = foldl' xor 0 $ elems a
  opts = evens $ tail $ scanl' xor 0 $ elems a
  splitPts = [i | axor == 0, (i, 0) <- zip [1, 3 ..] opts]
  in  case  splitPts  of
  [] -> Nothing
  k : _ -> Just $ [k - 2, k - 4 .. 1]
    ++ [3, 5 .. k - 2]
    ++ concat [[ii + 1, ii] | ii <- [k, k + 2 .. n - 3]] -- must step by two
    ++ [n - 2] -- don't forget last element

mainFun :: SO
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    aLi <- getInts n
    pure $ case  solve n aLi  of
      Just ans -> string7 "YES\n" <> putInts [length ans] <> putInts ans
      Nothing -> string7 "NO\n"

type SP = State [P.ByteString]
type SO = SP Builder

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

getInts :: Int -> SP [Int]
getInts k = do
  vs <- getNext k
  pure [v | Just (v, _) <- map P.readInt vs]

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

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

import qualified Data.ByteString.Lazy.Char8 as P
import Data.ByteString.Builder
import qualified Data.ByteString.Builder.Prim as Prim
import System.IO
import Control.Monad.Trans.State

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

evens :: [a] -> [a]
evens [] = []
evens (x0 : []) = x0 : []
evens (x0 : _x1 : xs) = x0 : evens xs

solve :: Int -> [Int] -> Maybe [Int]
solve n aLi = let
  a :: UArray Int Int
  a = listArray (1, n) aLi
  axor = foldl' xor 0 $ elems a
  opts = evens $ tail $ scanl' xor 0 $ elems a
  splitPts = [i | axor == 0, (i, 0) <- zip [1, 3 ..] opts]
  in  case  splitPts  of
  [] -> Nothing
  k : _ -> Just $ [k - 2, k - 4 .. 1] ++ [3, 5 .. k - 2] ++ do
    ii <- [k, k + 2 .. n - 3]
    [ii + 1, ii]

mainFun :: SO
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    aLi <- getInts n
    pure $ case  solve n aLi  of
      Just ans -> string7 "YES\n" <> putInts [length ans] <> putInts ans
      Nothing -> string7 "NO\n"

type SP = State [P.ByteString]
type SO = SP Builder

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

getInts :: Int -> SP [Int]
getInts k = do
  vs <- getNext k
  pure [v | Just (v, _) <- map P.readInt vs]

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

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

import qualified Data.ByteString.Lazy.Char8 as P
import Data.ByteString.Builder
import qualified Data.ByteString.Builder.Prim as Prim
import System.IO
import Control.Monad.Trans.State

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

evens :: [a] -> [a]
evens [] = []
evens (x0 : []) = x0 : []
evens (x0 : _x1 : xs) = x0 : evens xs

solve :: Int -> [Int] -> Maybe [Int]
solve n aLi = let
  a :: UArray Int Int
  a = listArray (1, n) aLi
  axor = foldl' xor 0 $ elems a
  opts = evens $ tail $ scanl' xor 0 $ elems a
  splitPts = [i | axor == 0, (i, 0) <- zip [1, 3 ..] opts]
  in  case  splitPts  of
  [] -> Nothing
  k : _ -> Just $ [k - 2, k - 4 .. 1] ++ [3, 5 .. k - 2] ++ do
    ii <- [k .. n - 3]
    [ii + 1, ii]

mainFun :: SO
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    aLi <- getInts n
    pure $ case  solve n aLi  of
      Just ans -> string7 "YES\n" <> putInts [length ans] <> putInts ans
      Nothing -> string7 "NO\n"

type SP = State [P.ByteString]
type SO = SP Builder

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

getInts :: Int -> SP [Int]
getInts k = do
  vs <- getNext k
  pure [v | Just (v, _) <- map P.readInt vs]

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

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


Boy Valera likes strings. And even more he likes them, when they are identical. That's why in his spare time Valera plays the following game. He takes any two strings, consisting of lower case Latin letters, and tries to make them identical. According to the game rules, with each move Valera can change one arbitrary character Ai in one of the strings into arbitrary character Bi, but he has to pay for every move a particular sum of money, equal to Wi. He is allowed to make as many moves as he needs. Since Valera is a very economical boy and never wastes his money, he asked you, an experienced programmer, to help him answer the question: what minimum amount of money should Valera have to get identical strings.

The first input line contains two initial non-empty strings s and t, consisting of lower case Latin letters. The length of each string doesn't exceed 105. The following line contains integer n (0 ≤ n ≤ 500) — amount of possible changings. Then follow n lines, each containing characters Ai and Bi (lower case Latin letters) and integer Wi (0 ≤ Wi ≤ 100), saying that it's allowed to change character Ai into character Bi in any of the strings and spend sum of money Wi.

If the answer exists, output the answer to the problem, and the resulting string. Otherwise output -1 in the only line. If the answer is not unique, output any.

abc
ab
6
a b 4
a b 7
b a 8
c b 11
c a 3
a c 0

import Array
import Char
main = interact (ans)
ans theInput = unlines ansList where
  s:t:n0:abw0 = lines theInput
  n = read n0 ::Int
  abw = [(c2i $ x!!0,c2i $ x!!2,read(drop 4 x)::Integer)|x<-(take n abw0)]
  c2i x = ord x - ord 'a'
  table [] = array ((0,0),(25,25)) [((a,b),if a==b then 0 else 999999999)|a<-[0..25],b<-[0..25]]
  table ((a,b,w):xs) = (table xs) // [((a,b),min w ( (table xs)!(a,b) ) )]
  wf 0 = table abw
  wf (m+1) = array((0,0),(25,25)) [((a,b),min ((wf m)!(a,b)) ( ((wf m)!(a,m))+((wf m)!(m,b)) ) ) |a<-[0..25],b<-[0..25]]
  final = wf 26
  cost t = array((0,0),(25,25)) [((x,y),foldr1 min [( (t!(x,z)) + (t!(y,z)),z )|z<-[0..25]])|x<-[0..25],y<-[0..25]]
  total = sum [fst (cf x y)|(x,y)<-zip s t]
  answord = [chr(snd (cf x y)+ord 'a') |(x,y)<-zip s t]
  cf x y = (cost final) ! (c2i x,c2i y)
  ansList = if total>999999998 || length s /= length t then ["-1"] else [show total,answord]

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, ForeignFunctionInterface  #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
-- import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.IORef
import Data.Int
import System.Exit
import Text.Printf
import qualified Foreign as F
import qualified Foreign.C as F

foreign import ccall unsafe "stdio.h printf"
  c_printf_I64d :: F.CString -> F.CLLong -> IO ()

foreign import ccall unsafe "stdio.h printf"
  c_printf_s :: F.CString -> F.CString -> IO ()

inf :: Int64
inf = 10 ^ 16

{-# SPECIALIZE for_ :: Char -> Char -> (Char -> IO ()) -> IO () #-}
{-# SPECIALIZE for_ :: Int -> Int -> (Int -> IO ()) -> IO () #-}
for_ :: (Monad m, Ord a, Enum a) => a -> a -> (a -> m ()) -> m ()
for_ i n f = loop i where
  loop i | i <= n    = f i >> loop (succ i)
         | otherwise = return ()

main :: IO ()
main = do
  let exit = print (-1) >> exitSuccess
      conv = fromIntegral . fst . fromJust . BS.readInt
  table <- newArray (('a', 'a'), ('z', 'z')) inf :: IO (IOUArray (Char, Char) Int64)
  F.withCString "%I64d\n" $ \fmt_I64d -> do
    F.withCString "%s\n" $ \fmt_s -> do
      for_ 'a' 'z' $ \c -> do
        writeArray table (c, c) 0
      s1 <- BS.filter (/= '\r') <$> BS.getLine
      s2 <- BS.filter (/= '\r') <$> BS.getLine
      -- s1 <- BS.getLine
      -- s2 <- BS.getLine
      when (BS.length s1 /= BS.length s2) $ exit
      n <- readLn
      for_ 1 n $ \i -> do
        from : to : s : _ <- BS.words <$> BS.getLine
        let idx = (BS.head from, BS.head to)
        v <- readArray table idx
        writeArray table idx $ min (conv s) v
      for_ 'a' 'z' $ \k -> do
        for_ 'a' 'z' $ \i -> do
          for_ 'a' 'z' $ \j -> do
            v  <- readArray table (i, j)
            v1 <- readArray table (i, k)
            v2 <- readArray table (k, j)
            when (v1 + v2 < v) $ do
              writeArray table (i, j) $ v1 + v2
      -- getAssocs table >>= print . filter ((/= inf) . snd)
      r <- newIORef 0 :: IO (IORef Int64)
      buf <- F.mallocArray0 101000 :: IO F.CString
      for_ 0 (BS.length s1 - 1) $ \i -> do
        let c1 = BS.index s1 i
            c2 = BS.index s2 i
            findMin = loop 'a' ('\0', inf) where
              loop to acc@(c, v)
                | 'z' < to  = return acc
                | otherwise = do
                    v1 <- readArray table (c1, to)
                    v2 <- readArray table (c2, to)
                    -- printf "%s\n" (show (c1, c2, to))
                    loop (succ to) $ if v1 + v2 < v then (to, v1 + v2) else acc
        (c, v) <- findMin
        when (c == '\0') $ exit
        modifyIORef r $ (+ v)
        F.poke (buf `F.advancePtr` i) (toEnum . fromEnum $ c)
      F.poke (buf `F.advancePtr` (BS.length s1)) (toEnum . fromEnum $ '\0')
      readIORef r >>= c_printf_I64d fmt_I64d . fromIntegral
      c_printf_s fmt_s buf
      F.free buf

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, ForeignFunctionInterface  #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
-- import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.IORef
import Data.Int
import System.Exit
import Text.Printf
import qualified Foreign as F
import qualified Foreign.C as F

foreign import ccall unsafe "stdio.h printf"
  c_printf_I64d :: F.CString -> F.CLLong -> IO ()

foreign import ccall unsafe "stdio.h printf"
  c_printf_s :: F.CString -> F.CString -> IO ()

inf :: Int64
inf = 10 ^ 16

{-# SPECIALIZE for_ :: Char -> Char -> (Char -> IO ()) -> IO () #-}
{-# SPECIALIZE for_ :: Int -> Int -> (Int -> IO ()) -> IO () #-}
for_ :: (Monad m, Ord a, Enum a) => a -> a -> (a -> m ()) -> m ()
for_ i n f = loop i where
  loop i | i <= n    = f i >> loop (succ i)
         | otherwise = return ()

main :: IO ()
main = do
  let exit = print (-1) >> exitSuccess
      conv = fromIntegral . fst . fromJust . BS.readInt
  table <- newArray (('a', 'a'), ('z', 'z')) inf :: IO (IOUArray (Char, Char) Int64)
  F.withCString "%I64d\n" $ \fmt_I64d -> do
    F.withCString "%s\n" $ \fmt_s -> do
      for_ 'a' 'z' $ \c -> do
        writeArray table (c, c) 0
      s1 <- BS.filter (/= '\r') <$> BS.getLine
      s2 <- BS.filter (/= '\r') <$> BS.getLine
      when (BS.length s1 /= BS.length s2) $ exit
      n <- readLn
      for_ 1 n $ \i -> do
        from : to : s : _ <- BS.words <$> BS.getLine
        let idx = (BS.head from, BS.head to)
        v <- readArray table idx
        writeArray table idx $ min (conv s) v
      for_ 'a' 'z' $ \k -> do
        for_ 'a' 'z' $ \i -> do
          for_ 'a' 'z' $ \j -> do
            v  <- readArray table (i, j)
            v1 <- readArray table (i, k)
            v2 <- readArray table (k, j)
            when (v1 + v2 < v) $ do
              writeArray table (i, j) $ v1 + v2
      -- getAssocs table >>= print . filter ((/= inf) . snd)
      r <- newIORef 0 :: IO (IORef Int64)
      buf <- F.mallocArray0 101000 :: IO F.CString
      for_ 0 (BS.length s1 - 1) $ \i -> do
        let c1 = BS.index s1 i
            c2 = BS.index s2 i
            findMin = loop 'a' ('\0', inf) where
              loop to acc@(c, v)
                | 'z' < to  = return acc
                | otherwise = do
                    v1 <- readArray table (c1, to)
                    v2 <- readArray table (c2, to)
                    -- printf "%s\n" (show (c1, c2, to))
                    loop (succ to) $ if v1 + v2 < v then (to, v1 + v2) else acc
        (c, v) <- findMin
        when (c == '\0') $ exit
        modifyIORef r $ (+ v)
        F.poke (buf `F.advancePtr` i) (toEnum . fromEnum $ c)
      F.poke (buf `F.advancePtr` (BS.length s1)) (toEnum . fromEnum $ '\0')
      readIORef r >>= c_printf_I64d fmt_I64d . fromIntegral
      c_printf_s fmt_s buf
      F.free buf

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

import Array
import Char
main = interact (ans)
ans theInput = unlines ansList where
  s:t:n0:abw0 = lines theInput
  n = read n0 ::Int
  abw = [(c2i $ x!!0,c2i $ x!!2,read(drop 4 x)::Integer)|x<-(take n abw0)]
  c2i x = ord x - ord 'a'
  table [] = array ((0,0),(25,25)) [((a,b),if a==b then 0 else 999999999)|a<-[0..25],b<-[0..25]]
  table ((a,b,w):xs) = (table xs) // [((a,b),min w ( (table xs)!(a,b) ) )]
  wf 0 = table abw
  wf (m+1) = array((0,0),(25,25)) [((a,b),min ((wf m)!(a,b)) ( ((wf m)!(a,m))+((wf m)!(m,b)) ) ) |a<-[0..25],b<-[0..25]] where
  final = wf 26
  cost t = array((0,0),(25,25)) [((x,y),foldr1 min [( (t!(x,z)) + (t!(y,z)),z )|z<-[0..25]])|x<-[0..25],y<-[0..25]]
  total = sum [fst (cf x y)|(x,y)<-zip s t]
  answord = [chr(snd (cf x y)+ord 'a') |(x,y)<-zip s t]
  cf x y = (cost final) ! (c2i x,c2i y)
  ansList = if total>999999998 || length s /= length t then ["-1"] else [show total,answord]

import Array
import Char
main = interact (ans)
ans theInput = unlines ansList where
  s:t:n0:abw0 = lines theInput
  n = read n0 ::Int
  abw = [(c2i $ x!!0,c2i $ x!!2,read(drop 4 x)::Int)|x<-(take n abw0)]
  c2i x = ord x - ord 'a'
  table [] = array ((0,0),(25,25)) [((a,b),if a==b then 0 else 9999)|a<-[0..25],b<-[0..25]]
  table ((a,b,w):xs) = (table xs) // [((a,b),min w ((table xs)!(a,b)))]
  wf 0 = table abw
  wf (m+1) = array((0,0),(25,25))
    [((a,b),foldr min ((wf m)!(a,b)) [ ((wf m)!(a,m)+(wf m)!(m,b)) , 9999] )|a<-[0..25],b<-[0..25]]
  final = wf 26
  cost t = array((0,0),(25,25)) [((x,y),foldr min (9999,-1) [(t!(x,z)+t!(y,z),z)|z<-[0..25]])|x<-[0..25],y<-[0..25]]
  total = sum [fst (cf x y)|(x,y)<-zip s t]
  answord = [chr(snd (cf x y)+ord 'a') |(x,y)<-zip s t]
  cf x y = (cost final) ! (c2i x,c2i y)
  ansList = if total>9998 || length s /= length t then ["-1"] else [show total,answord]

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
-- import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Data.Map as Map
-- import qualified Data.Set as Set
-- import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.Array.Unboxed
import System.Exit

main :: IO ()
main = do
  let readData :: IO [Int]
      readData = map read . words <$> getLine
      -- readData = map (fst . fromJust . BS.readInt) . BS.words <$> BS.getLine
      exit = print (-1) >> exitSuccess
  s1 <- getLine
  s2 <- getLine
  when (length s1 /= length s2) $  exit
  n <- readLn
  cs <- T.for [1 .. n] $ \i -> do
    from : to : v: _ <- words <$> getLine
    return (head from, Map.singleton (head to) (read v :: Int))
  let mp = Map.fromListWith (Map.unionWith min) cs
      bnds = (('a', 'a'), ('z', 'z'))
  table <- newArray bnds maxBound :: IO (IOArray (Char, Char) Int)
  F.for_ (zip ['a' .. 'z'] ['a' .. 'z']) $ \idx -> do
    writeArray table idx 0
  let fill from cost now = F.for_ (Map.lookup now mp) $ \mp' -> do
        F.for_ (Map.toList mp') $ \(to, new) -> do
          old <- readArray table (now, to)
          when (old == maxBound || new < old) $ do
            writeArray table (now, to) new
            let new' = cost + new
            old' <- readArray table (from, to)
            when (old' == maxBound || new' < old') $ do
              writeArray table (from, to) new'
            fill from new' to
  F.for_ ['a' .. 'z'] $ \c -> fill c 0 c

  let check c1 c2
        | c1 == c2  = return (c1, 0)
        | otherwise = do
            xs <- T.for ['a' .. 'z'] $ \to -> do
              v1 <- readArray table (c1, to)
              v2 <- readArray table (c2, to)
              case () of
                _ | c1 == to  -> return (to, v2)
                  | c2 == to  -> return (to, v1)
                  | otherwise -> return (to, min v1 v2)
            when (null xs) $ exit
            let (c, cost) = minimumBy (comparing snd) xs
            if cost == maxBound
              then exit
              else do
                return (c, cost)
  (answer, cost) <- unzip <$> zipWithM check s1 s2
--  getAssocs table >>= printf "%s\n" . show
  print $ sum cost
  putStrLn answer

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
-- import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Data.Map as Map
-- import qualified Data.Set as Set
-- import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.Array.Unboxed
import System.Exit

inf :: Integer
inf = 10 ^ 20

main :: IO ()
main = do
  let readData :: IO [Int]
      readData = map read . words <$> getLine
      -- readData = map (fst . fromJust . BS.readInt) . BS.words <$> BS.getLine
      exit = print (-1) >> exitSuccess
  s1 <- getLine
  s2 <- getLine
  when (length s1 /= length s2) $  exit
  n <- readLn
  cs <- T.for [1 .. n] $ \i -> do
    from : to : v: _ <- words <$> getLine
    return (head from, Map.singleton (head to) (read v :: Integer))
  let mp = Map.fromListWith (Map.unionWith min) cs
      bnds = (('a', 'a'), ('z', 'z'))
  table <- newArray bnds inf :: IO (IOArray (Char, Char) Integer)
  F.for_ (zip ['a' .. 'z'] ['a' .. 'z']) $ \idx -> do
    writeArray table idx 0
  let fill from cost now = F.for_ (Map.lookup now mp) $ \mp' -> do
        F.for_ (Map.toList mp') $ \(to, new) -> do
          old <- readArray table (now, to)
          when (old == inf || new < old) $ do
            writeArray table (now, to) new
            let new' = cost + new
            old' <- readArray table (from, to)
            when (old' == inf || new' < old') $ do
              writeArray table (from, to) new'
            fill from new' to
  F.for_ ['a' .. 'z'] $ \c -> fill c 0 c
  let check c1 c2
        | c1 == c2  = return (c1, 0)
        | otherwise = do
            xs <- T.for ['a' .. 'z'] $ \to -> do
              v1 <- readArray table (c1, to)
              v2 <- readArray table (c2, to)
              case () of
                _ | c1 == to  -> return (to, v2)
                  | c2 == to  -> return (to, v1)
                  | otherwise -> return (to, v1 + v2)
            when (null xs) $ exit
            let (c, cost) = minimumBy (comparing snd) xs
            if cost == inf
              then exit
              else do
                return (c, cost)
  (answer, cost) <- unzip <$> zipWithM check s1 s2
--  getAssocs table >>= printf "%s\n" . show
  print $ sum cost
  putStrLn answer

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, ForeignFunctionInterface  #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
-- import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.IORef
import Data.Int
import System.Exit
import Text.Printf
import qualified Foreign as F
import qualified Foreign.C as F

foreign import ccall unsafe "stdio.h puts"
  puts :: F.CString -> IO ()

inf :: Int64
inf = 10 ^ 16

{-# SPECIALIZE for_ :: Char -> Char -> (Char -> IO ()) -> IO () #-}
{-# SPECIALIZE for_ :: Int -> Int -> (Int -> IO ()) -> IO () #-}
for_ :: (Monad m, Ord a, Enum a) => a -> a -> (a -> m ()) -> m ()
for_ i n f = loop i where
  loop i | i <= n    = f i >> loop (succ i)
         | otherwise = return ()

main :: IO ()
main = do
  let exit = print (-1) >> exitSuccess
      conv = fromIntegral . fst . fromJust . BS.readInt
  table <- newArray (('a', 'a'), ('z', 'z')) inf :: IO (IOUArray (Char, Char) Int64)
  for_ 'a' 'z' $ \c -> do
    writeArray table (c, c) 0
  s1 <- BS.filter (/= '\r') <$> BS.getLine
  s2 <- BS.filter (/= '\r') <$> BS.getLine
  when (BS.length s1 /= BS.length s2) $ exit
  n <- readLn
  for_ 1 n $ \i -> do
    from : to : s : _ <- BS.words <$> BS.getLine
    let idx = (BS.head from, BS.head to)
    v <- readArray table idx
    writeArray table idx $ min (conv s) v
  for_ 'a' 'z' $ \k -> do
    for_ 'a' 'z' $ \i -> do
      for_ 'a' 'z' $ \j -> do
        v  <- readArray table (i, j)
        v1 <- readArray table (i, k)
        v2 <- readArray table (k, j)
        when (v1 + v2 < v) $ do
          writeArray table (i, j) $ v1 + v2
  -- getAssocs table >>= print . filter ((/= inf) . snd)
  r <- newIORef 0 :: IO (IORef Int64)
  buf <- F.mallocArray0 101000 :: IO F.CString
  for_ 0 (BS.length s1 - 1) $ \i -> do
    let c1 = BS.index s1 i
        c2 = BS.index s2 i
        findMin = loop 'a' ('\0', inf) where
          loop to acc@(c, v)
            | 'z' < to  = return acc
            | otherwise = do
                v1 <- readArray table (c1, to)
                v2 <- readArray table (c2, to)
                -- printf "%s\n" (show (c1, c2, to))
                loop (succ to) $ if v1 + v2 < v then (to, v1 + v2) else acc
    (c, v) <- findMin
    when (c == '\0') $ exit
    modifyIORef r $ (+ v)
    F.poke (buf `F.advancePtr` i) (toEnum . fromEnum $ c)
  F.poke (buf `F.advancePtr` (BS.length s1)) (toEnum . fromEnum $ '\0')
  readIORef r >>= print
  puts buf
  F.free buf

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
-- import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Data.Map as Map
-- import qualified Data.Set as Set
-- import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.Array.Unboxed
import System.Exit

inf :: Integer
inf = 10 ^ 20

main :: IO ()
main = do
  let readData :: IO [Int]
      readData = map read . words <$> getLine
      -- readData = map (fst . fromJust . BS.readInt) . BS.words <$> BS.getLine
      exit = print (-1) >> exitSuccess
  s1 <- getLine
  s2 <- getLine
  when (length s1 /= length s2) $  exit
  n <- readLn
  cs <- T.for [1 .. n] $ \i -> do
    from : to : v: _ <- words <$> getLine
    return (head from, Map.singleton (head to) (read v :: Integer))
  let mp = Map.fromListWith (Map.unionWith min) cs
      bnds = (('a', 'a'), ('z', 'z'))
  table <- newArray bnds inf :: IO (IOArray (Char, Char) Integer)
  F.for_ (zip ['a' .. 'z'] ['a' .. 'z']) $ \idx -> do
    writeArray table idx 0
  let fill from cost now = F.for_ (Map.lookup now mp) $ \mp' -> do
        F.for_ (Map.toList mp') $ \(to, new) -> do
          old <- readArray table (now, to)
          when (old == inf || new < old) $ do
            writeArray table (now, to) new
            let new' = cost + new
            old' <- readArray table (from, to)
            when (old' == inf || new' < old') $ do
              writeArray table (from, to) new'
            fill from new' to
  F.for_ ['a' .. 'z'] $ \c -> fill c 0 c
  let check c1 c2
        | c1 == c2  = return (c1, 0)
        | otherwise = do
            xs <- T.for ['a' .. 'z'] $ \to -> do
              v1 <- readArray table (c1, to)
              v2 <- readArray table (c2, to)
              case () of
                _ | c1 == to  -> return (to, v2)
                  | c2 == to  -> return (to, v1)
                  | otherwise -> return (to, min v1 v2)
            when (null xs) $ exit
            let (c, cost) = minimumBy (comparing snd) xs
            if cost == inf
              then exit
              else do
                return (c, cost)
  (answer, cost) <- unzip <$> zipWithM check s1 s2
--  getAssocs table >>= printf "%s\n" . show
  print $ sum cost
  putStrLn answer

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
-- import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Data.Map as Map
-- import qualified Data.Set as Set
-- import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.Array.Unboxed
import System.Exit

main :: IO ()
main = do
  let readData :: IO [Int]
      readData = map read . words <$> getLine
      -- readData = map (fst . fromJust . BS.readInt) . BS.words <$> BS.getLine
      exit = print (-1) >> exitSuccess
  s1 <- getLine
  s2 <- getLine
  when (length s1 /= length s2) $  exit
  n <- readLn
  cs <- T.for [1 .. n] $ \i -> do
    from : to : v: _ <- words <$> getLine
    return (head from, Map.singleton (head to) (read v :: Int))
  let mp = Map.fromListWith (Map.unionWith min) cs
      bnds = (('a', 'a'), ('z', 'z'))
  table <- newArray bnds maxBound :: IO (IOArray (Char, Char) Int)
--  F.for_ (zip ['a' .. 'z'] ['a' .. 'z']) $ \idx -> do
--    writeArray table idx 0
  let fill from cost now = F.for_ (Map.lookup now mp) $ \mp' -> do
        F.for_ (Map.toList mp') $ \(to, new) -> do
          old <- readArray table (now, to)
          when (old == maxBound || new < old) $ do
            writeArray table (now, to) new
            let new' = cost + new
            old' <- readArray table (from, to)
            when (old' == maxBound || new' < old') $ do
              writeArray table (from, to) new'
            fill from new' to
  F.for_ ['a' .. 'z'] $ \c -> fill c 0 c
  let check c1 c2
        | c1 == c2  = return (c1, 0)
        | otherwise = do
            xs <- T.for ['a' .. 'z'] $ \to -> do
              v1 <- readArray table (c1, to)
              v2 <- readArray table (c2, to)
              case () of
                _ | c1 == to  -> return (to, v2)
                  | c2 == to  -> return (to, v1)
                  | otherwise -> return (to, min v1 v2)
            when (null xs) $ exit
            let (c, cost) = minimumBy (comparing snd) xs
            if cost == maxBound
              then exit
              else do
                return (c, cost)
  (answer, cost) <- unzip <$> zipWithM check s1 s2
--  getAssocs table >>= printf "%s\n" . show
  print $ sum cost
  putStrLn answer

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
-- import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Data.Map as Map
-- import qualified Data.Set as Set
-- import qualified Data.ByteString.Char8 as BS
import Text.Printf
import System.Exit

main :: IO ()
main = do
  let readData :: IO [Int]
      readData = map read . words <$> getLine
      -- readData = map (fst . fromJust . BS.readInt) . BS.words <$> BS.getLine
      exit = print (-1) >> exitSuccess
  s1 <- getLine
  s2 <- getLine
  when (length s1 /= length s2) $ exit
  n <- readLn
  init <- fmap (Map.fromListWith min) . T.for [1 .. n] $ \i -> do
    from : to : v: _ <- words <$> getLine
    return ((head from, head to), (read v :: Integer))
  let mp = foldl check init ['a' .. 'z']
      check acc k = foldl f acc [(i, j) | i <- ['a' .. 'z'], j <- ['a' .. 'z']]
        where f acc' (i, j) = maybe acc' g $ do
                v1 <- Map.lookup (i, k) acc'
                v2 <- Map.lookup (k, j) acc'
                return $ v1 + v2
                where g v = maybe (Map.insert (i, j) v acc') id $ do
                        v' <- Map.lookup (i, j) acc'
                        return $ if v < v'
                                   then Map.insert (i, j) v acc'
                                   else acc'
  let best c1 c2
        | c1 == c2  = return (c1, 0)
        | otherwise = do
            xs <- fmap concat . T.for ['a' .. 'z'] $ \to -> do
              return . maybe [] (return . (,) to) $ do
                case () of
                  _ | c1 == to  -> Map.lookup (c2, to) mp
                    | c2 == to  -> Map.lookup (c1, to) mp
                    | otherwise -> do
                        v1 <- Map.lookup (c1, to) mp
                        v2 <- Map.lookup (c2, to) mp
                        return $ min v1 v2
            when (null xs) $ exit
            return $ minimumBy (comparing snd) xs
  (answer, cost) <- fmap sum . unzip <$> zipWithM best s1 s2
  -- print mp
  print cost
  putStrLn answer

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}


Furik loves math lessons very much, so he doesn't attend them, unlike Rubik. But now Furik wants to get a good mark for math. For that Ms. Ivanova, his math teacher, gave him a new task. Furik solved the task immediately. Can you?You are given a set of digits, your task is to find the maximum integer that you can make from these digits. The made number must be divisible by 2, 3, 5 without a residue. It is permitted to use not all digits from the set, it is forbidden to use leading zeroes.Each digit is allowed to occur in the number the same number of times it occurs in the set.

A single line contains a single integer n (1 ≤ n ≤ 100000) — the number of digits in the set. The second line contains n digits, the digits are separated by a single space.

On a single line print the answer to the problem. If such number does not exist, then you should print -1.

NoteIn the first sample there is only one number you can make — 0. In the second sample the sought number is 5554443330. In the third sample it is impossible to make the required number.

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

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

main = getLine >> do
  cnts <- map (pred.length).group.sort.([0..9]++).map readInt.B.words <$> B.getLine
  if cnts!!0 == 0
     then print $ -1
     else putStrLn.f.solve $ cnts

f (0:_) = "0"
f ns = ns>>=show

g cnts = do
  i<-[9,8..0]
  replicate (cnts!!i) i

del i xs = let (ys,x:zs)=splitAt i xs
           in ys++(x-1):zs

solve :: [Int] -> [Int]
solve cnts = case (`mod`3) $ sum $ zipWith (*) cnts [0..9] of
             0 -> g cnts
             1 | (x:_)<-filter((>0).(cnts!!))[1,4,7] -> g $ del x cnts
               | (x:_)<-filter((>1).(cnts!!))[2,5,8] -> g $ del x $ del x cnts
               | (x:y:_)<-filter((>0).(cnts!!))[2,5,8] -> g $ del x $ del y cnts
             2 | (x:_)<-filter((>0).(cnts!!))[2,5,8] -> g $ del x cnts
               | (x:_)<-filter((>1).(cnts!!))[1,4,7] -> g $ del x $ del x cnts
               | (x:y:_)<-filter((>0).(cnts!!))[1,4,7] -> g $ del x $ del y cnts
             _ -> [-1]

import Data.Char (intToDigit)
import Data.List (sort, delete)
extract f = filter (f . (`mod` 3))
solve :: [Int] -> Maybe [Int]
solve xs
    | 0 `notElem` xs = Nothing
    | otherwise =
        case pl `mod` 3 of
            0 -> Just $ reverse ss
            1 -> factored 1
            2 -> factored 2
    where pl = sum xs
          ss = sort xs
          ms = extract (/=0) ss
          factored h = case safeFind h ms of
                (_, Just x) -> Just $ reverse $ delete x ss
                _ -> case safeFind (3 - h) ms of
                    (Just y, Just x) -> Just $ reverse $ delete y $ delete x $ ss
                    _ -> Nothing
safeFind :: Int -> [Int] -> (Maybe Int, Maybe Int)
safeFind m ps =
    case extract (==m) ps of
        [] -> (Nothing, Nothing)
        [x] -> (Nothing, Just x)
        (y:x:s) -> (Just y, Just x)

parse :: Maybe [Int] -> String
parse Nothing  = "-1"
parse (Just v) = if all (==0) v then "0" else map intToDigit v

main = putStrLn.parse.solve.map read.tail.words =<< getContents

import Data.Char (intToDigit)
import Data.List (sort, delete)
extract f = filter (f . (`mod` 3))
solve :: [Int] -> Maybe [Int]
solve xs
    | 0 `notElem` xs = Nothing
    | otherwise = if md == 0 then Just ss else factored md
    where md = sum xs `mod` 3
          ss = sort xs
          ms = extract (/=0) ss
          factored h = case extract (==h) ms of
                (x:_) -> Just (delete x ss)
                _ -> case extract (==(3 - h)) ms of
                    (y:x:_) -> Just (delete y (delete x ss))
                    _ -> Nothing
parse :: Maybe [Int] -> String
parse Nothing  = "-1"
parse (Just v) = if all (==0) v then "0" else map intToDigit (reverse v)
main = putStrLn.parse.solve.map read.tail.words =<< getContents

import Data.List

solve :: [Int] -> [Int]
solve ds
    | all (/= 0) ts = []
    | all (== 0) ts = [0]
    | otherwise = reverse ts
    where r = sum ds `mod` 3
          xs = sort ds
          ps = map (\x -> filter (\y -> y `mod` 3 == x) xs) [0, 1, 2]
          ts | r == 0 = xs
             | null $ ps !! r = xs \\ (take 2 (ps !! (3 - r)))
             | otherwise = delete (ps !! r !! 0) xs

readInput :: IO [Int]
readInput = do
    contents <- getContents
    let x:xs = words contents
        ds = map read $ take (read x) xs
    return ds

showOutput :: [Int] -> IO ()
showOutput xs = do
    putStrLn $ if null xs then "-1" else concat $ map show xs

main :: IO ()
main = do
    input <- readInput
    showOutput $ solve input

import Data.List

solve :: [Int] -> [Int]
solve ds
    | all (/= 0) ts = []
    | all (== 0) ts = [0]
    | otherwise = reverse ts
    where r = sum ds `mod` 3
          xs = sort ds
          ps = map (\x -> filter (\y -> y `mod` 3 == x) xs) [0, 1, 2]
          ts | r == 0 = xs
             | null $ ps !! r = xs \\ (take 2 (ps !! (3 - r)))
             | otherwise = delete (ps !! r !! 0) xs

readInput :: IO [Int]
readInput = do
    contents <- getContents
    let n:ns = words contents
        ds = map read $ take (read n) ns
    return ds

showOutput :: [Int] -> IO ()
showOutput ds = do
    putStrLn $ if null ds then "-1" else concat $ map show ds

main :: IO ()
main = do
    input <- readInput
    showOutput $ solve input

import Data.Char (intToDigit)
import Data.List (sort, delete)
extract f = filter (f . (`mod` 3))
solve :: [Int] -> Maybe [Int]
solve xs
    | 0 `notElem` xs = Nothing
    | all (==0) xs = Just [0]
    | otherwise =
        case pl `mod` 3 of
            0 -> Just $ reverse ss
            1 -> factored 1
            2 -> factored 2
    where pl = sum xs
          ss = sort xs
          ms = extract (/=0) ss
          factored h = case safeFind h ms of
                (_, Just x) -> Just $ reverse $ delete x ss
                _ -> case safeFind (3 - h) ms of
                    (Just y, Just x) -> Just $ reverse $ delete y $ delete x $ ss
                    _ -> Nothing
safeFind :: Int -> [Int] -> (Maybe Int, Maybe Int)
safeFind m ps =
    case extract (==m) ps of
        [] -> (Nothing, Nothing)
        [x] -> (Nothing, Just x)
        (y:x:s) -> (Just y, Just x)

parse :: Maybe [Int] -> String
parse Nothing  = "-1"
parse (Just v) = map intToDigit v

main = putStrLn.parse.solve.map read.tail.words =<< getContents

import Data.List

solve :: [Int] -> [Int]
solve xs
    | all (/= 0) ts = []
    | all (== 0) ts = [0]
    | otherwise = reverse $ sort ts
    where r = sum xs `mod` 3
          ps = map (\x -> filter (\y -> y `mod` 3 == x) xs) [0, 1, 2]
          ts | r == 0 = xs
             | null $ ps !! r = xs \\ (take 2 (ps !! (3 - r)))
             | otherwise = delete (ps !! r !! 0) xs

readInput :: IO [Int]
readInput = do
    contents <- getContents
    let x:xs = words contents
        ds = map read $ take (read x) xs
    return ds

showOutput :: [Int] -> IO ()
showOutput xs = do
    putStrLn $ if null xs then "-1" else concat $ map show xs

main :: IO ()
main = do
    input <- readInput
    showOutput $ solve input


Little Petya likes arrays of integers a lot. Recently his mother has presented him one such array consisting of n elements. Petya is now wondering whether he can swap any two distinct integers in the array so that the array got unsorted. Please note that Petya can not swap equal integers even if they are in distinct positions in the array. Also note that Petya must swap some two integers even if the original array meets all requirements.Array a (the array elements are indexed from 1) consisting of n elements is called sorted if it meets at least one of the following two conditions:  a1 ≤ a2 ≤ ... ≤ an;  a1 ≥ a2 ≥ ... ≥ an. Help Petya find the two required positions to swap or else say that they do not exist.

The first line contains a single integer n (1 ≤ n ≤ 105). The second line contains n non-negative space-separated integers a1, a2, ..., an — the elements of the array that Petya's mother presented him. All integers in the input do not exceed 109.

If there is a pair of positions that make the array unsorted if swapped, then print the numbers of these positions separated by a space. If there are several pairs of positions, print any of them. If such pair does not exist, print -1. The positions in the array are numbered with integers from 1 to n.

NoteIn the first two samples the required pairs obviously don't exist.In the third sample you can swap the first two elements. After that the array will look like this: 2 1 3 4. This array is unsorted.

-- Codeforces 252B

{-# OPTIONS_GHC -O2 #-}
{-# OPTIONS_GHC -funfolding-use-threshold=16 #-}
{-# OPTIONS_GHC -fexcess-precision #-}
{-# OPTIONS_GHC -feager-blackholing #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# OPTIONS_GHC -fdicts-strict #-}
{-# OPTIONS_GHC -optc-O3 #-}
{-# OPTIONS_GHC -optc-ffast-math #-}

import Control.Applicative
import Data.Maybe
import qualified Data.ByteString.Char8 as BC

main :: IO ()
main = do
    n <- read <$> getLine :: IO Int
    xs <- (map (fst . fromJust . BC.readInt) . BC.words) <$> BC.getContents :: IO [Int]
    putStrLn . unwords . map show . go . zip [1..] $ xs
  where
    go ((x1,v1):(x2,v2):(x3,v3):vs)
      | v1 == v2 && v2 == v3 = go $ (x2,v2):(x3,v3):vs
      | v1 == v2 = [x2, x3]
      | v2 == v3 = [x1, x2]
      | v1 > v2 && v2 > v3 = [x1, x2]
      | v1 < v2 && v2 < v3 = [x1, x2]
      | v1 /= v3 = [x1, x3]
      | null vs = [-1]
      | v1 == v4 = [x2, x3]
      | v2 == v4 = [x1, x2]
      | v3 == v4 = [x2, x3]
      | otherwise = [x3, x4]
      where (x4, v4) = head vs
    go _ = [-1]

import qualified Data.ByteString.Char8 as B

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

main = B.getContents>>=putStrLn.unwords.map show.solve.zip[1..].tail.map readInt.B.words

solve :: [(Int,Int)] -> [Int]
solve ((i,x):(j,y):(k,z):rest)
  | x==y && y==z = solve ((j,y):(k,z):rest)
  | x==y = [j,k]
  | y==z || x<y && y<z || x>y && y>z = [i,j]
  | z/=x = [i,k]
  | null rest = [-1]
  | x == w = [j,k]
  | y == w = [i,j]
  | otherwise = [k,l]
   where
     (l,w) = head rest
solve _ = [-1]

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 = do
  n <- readLn :: IO Int
  if n<=2
     then print $ -1
     else B.getContents>>=putStrLn.unwords.map show.solve.zip[1..].map readInt.B.words

solve :: [(Int,Int)] -> [Int]
solve ((i,x):(j,y):(k,z):rest)
  | x==y && y==z = solve ((j,y):(k,z):rest)
  | x==y = [j,k]
  | y==z = [i,j]
  | z==x = solve ((i,x):(j,y):rest)
  | x<y  && y<z  = [i,j]
  | z>y  && y>x  = [i,j]
  | otherwise = [i,k]
solve _ = [-1]

import qualified Data.ByteString.Char8 as B

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

main = B.getContents>>=putStrLn.unwords.map show.solve.zip[1..].tail.map readInt.B.words

solve :: [(Int,Int)] -> [Int]
solve ((i,x):(j,y):(k,z):rest)
  | x==y && y==z = solve ((j,y):(k,z):rest)
  | x==y = [j,k]
  | y==z || x<y && y<z || x>y && y>z = [i,j]
  | z/=x = [i,k]
  | null rest = [-1]
  | y == w = [i,j]
  | otherwise = [k,l]
   where
     (l,w) = head rest
solve _ = [-1]


Local authorities have heard a lot about combinatorial abilities of Ostap Bender so they decided to ask his help in the question of urbanization. There are n people who plan to move to the cities. The wealth of the i of them is equal to ai. Authorities plan to build two cities, first for n1 people and second for n2 people. Of course, each of n candidates can settle in only one of the cities. Thus, first some subset of candidates of size n1 settle in the first city and then some subset of size n2 is chosen among the remaining candidates and the move to the second city. All other candidates receive an official refuse and go back home.To make the statistic of local region look better in the eyes of their bosses, local authorities decided to pick subsets of candidates in such a way that the sum of arithmetic mean of wealth of people in each of the cities is as large as possible. Arithmetic mean of wealth in one city is the sum of wealth ai among all its residents divided by the number of them (n1 or n2 depending on the city). The division should be done in real numbers without any rounding.Please, help authorities find the optimal way to pick residents for two cities.

The first line of the input contains three integers n, n1 and n2 (1 ≤ n, n1, n2 ≤ 100 000, n1 + n2 ≤ n) — the number of candidates who want to move to the cities, the planned number of residents of the first city and the planned number of residents of the second city. The second line contains n integers a1, a2, ..., an (1 ≤ ai ≤ 100 000), the i-th of them is equal to the wealth of the i-th candidate.

Print one real value — the maximum possible sum of arithmetic means of wealth of cities' residents. You answer will be considered correct if its absolute or relative error does not exceed 10 - 6.  Namely: let's assume that your answer is a, and the answer of the jury is b. The checker program will consider your answer correct, if .

NoteIn the first sample, one of the optimal solutions is to move candidate 1 to the first city and candidate 2 to the second.In the second sample, the optimal solution is to pick candidates 3 and 4 for the first city, and candidate 2 for the second one. Thus we obtain (a3 + a4) / 2 + a2 = (3 + 2) / 2 + 4 = 6.5

import Data.List( sortBy)
import Data.Ratio
main = do
    let readLine = return . map read . words =<< getLine
    [n_,n1_,n2_] <- readLine::IO [Int]
    ws_ <- readLine::IO [Int]
    let nmax = maximum [n1_,n2_]
	nmin = minimum [n1_,n2_]
	(minCity,rest) = splitAt nmin $ sortBy (flip compare) ws_
	maxCity = take nmax rest
	value = (sum.map toInteger$minCity)%(toInteger nmin) +
		    (sum.map toInteger$maxCity)%(toInteger nmax)
    print $ fromRational value

import Data.List( sortBy)
import Data.Ratio
main = do
    let readLine = return . map read . words =<< getLine
    [n_,n1_,n2_] <- readLine
    ws_ <- readLine
    let nmax = maximum [n1_,n2_]
	nmin = minimum [n1_,n2_]
	(minCity,rest) = splitAt nmin $ sortBy (flip compare) ws_
	maxCity = take nmax rest
	value = (sum minCity)%nmin + (sum maxCity)%nmax
	result = (fromIntegral $ numerator value) /
		    (fromIntegral $ denominator value)
    print result


You are the owner of a harvesting field which can be modeled as an infinite line, whose positions are identified by integers.It will rain for the next $$$n$$$ days. On the $$$i$$$-th day, the rain will be centered at position $$$x_i$$$ and it will have intensity $$$p_i$$$. Due to these rains, some rainfall will accumulate; let $$$a_j$$$ be the amount of rainfall accumulated at integer position $$$j$$$. Initially $$$a_j$$$ is $$$0$$$, and it will increase by $$$\max(0,p_i-|x_i-j|)$$$ after the $$$i$$$-th day's rain.A flood will hit your field if, at any moment, there is a position $$$j$$$ with accumulated rainfall $$$a_j>m$$$.You can use a magical spell to erase exactly one day's rain, i.e., setting $$$p_i=0$$$. For each $$$i$$$ from $$$1$$$ to $$$n$$$, check whether in case of erasing the $$$i$$$-th day's rain there is no flood.

Each test contains multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \leq t \leq 10^4$$$). The description of the test cases follows. The first line of each test case contains two integers $$$n$$$ and $$$m$$$ ($$$1 \leq n \leq 2 \cdot 10^5$$$, $$$1 \leq m \leq 10^9$$$) — the number of rainy days and the maximal accumulated rainfall with no flood occurring. Then $$$n$$$ lines follow. The $$$i$$$-th of these lines contains two integers $$$x_i$$$ and $$$p_i$$$ ($$$1 \leq x_i,p_i \leq 10^9$$$) — the position and intensity of the $$$i$$$-th day's rain. The sum of $$$n$$$ over all test cases does not exceed $$$2 \cdot 10^5$$$.

For each test case, output a binary string $$$s$$$ length of $$$n$$$. The $$$i$$$-th character of $$$s$$$ is 1 if after erasing the $$$i$$$-th day's rain there is no flood, while it is 0, if after erasing the $$$i$$$-th day's rain the flood still happens.

NoteIn the first test case, if we do not use the spell, the accumulated rainfall distribution will be like this:  If we erase the third day's rain, the flood is avoided and the accumulated rainfall distribution looks like this:  In the second test case, since initially the flood will not happen, we can erase any day's rain.In the third test case, there is no way to avoid the flood.

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

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
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)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.Map 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'))
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 qualified Data.IntMap as IntMap

type Domain = (Int, [(Int, Int)])
type CoDomain = [Bool]
type Solver  = Domain -> CoDomain

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

getPair :: IO (Int, Int)
getPair = do
  [a, b] <- readChar8
  return (a, b)

printAns :: CoDomain -> IO ()
printAns = putStrLn . showResult

parse :: IO Domain
parse = do
  [n, m] <- readChar8
  xs <- replicateM n getPair
  return (m, xs)

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

solve :: Solver
solve (m, xs) = result
  where
    mapAcc =  IntMap.unionsWith (+) $ (\(x,y) -> IntMap.fromList [(x-y, 1), (x, (-2)), (x+y, 1)]) <$> xs
    heights = tail $ toHeight <$> scanl f (0, 0, 0) (IntMap.toAscList mapAcc)
    highPoints = filter ((> m) . snd) heights
    leftMost = minimum $ (+m) <$> uncurry (-) <$> highPoints
    rightMost = maximum $ (+(-m)) <$> uncurry (+) <$> highPoints
    result = (\(x, y) -> null highPoints || x - y <= leftMost && x + y >= rightMost) <$> xs
    f (pos, ac, height) (nPos, acc) = (nPos, ac + acc, height + (nPos - pos) * ac)
    toHeight (xPos, _, height) = (xPos, height)

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

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

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
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)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.Map 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'))
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 qualified Data.IntMap as IntMap

type Domain = (Int, [(Int, Int)])
type CoDomain = [Bool]
type Solver  = Domain -> CoDomain

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

getPair :: IO (Int, Int)
getPair = do
  [a, b] <- readChar8
  return (a, b)

printAns :: CoDomain -> IO ()
printAns = putStrLn . showResult

parse :: IO Domain
parse = do
  [n, m] <- readChar8
  xs <- replicateM n getPair
  return (m, xs)

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

solve :: Solver
solve (m, xs) = result
  where
    mapAcc =  foldl' (\acc (x,y) -> IntMap.unionWith (+) (IntMap.fromList [(x-y, 1), (x, (-2)), (x+y, 1)]) acc) IntMap.empty xs
    heights = tail $ toHeight <$> scanl f (0, 0, 0) (IntMap.toAscList mapAcc)
    highPoints = filter ((> m) . snd) heights
    leftMost = minimum $ (+m) <$> uncurry (-) <$> highPoints
    rightMost = maximum $ (+(-m)) <$> uncurry (+) <$> highPoints
    result = (\(x, y) -> null highPoints || x - y <= leftMost && x + y >= rightMost) <$> xs
    f (pos, ac, height) (nPos, acc) = (nPos, ac + acc, height + (nPos - pos) * ac)
    toHeight (xPos, _, height) = (xPos, height)

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

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

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
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)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.Map 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'))
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 qualified Data.IntMap as IntMap

type Domain = (Int, [(Int, Int)])
type CoDomain = [Bool]
type Solver  = Domain -> CoDomain

-- x in a
-- (x, y, a, b)
-- (start x, end x, start y, y per x unit )
type Segment = (Int, Int, Int, Int)

lookupSegGT :: Segment -> Set Segment -> Maybe Segment
lookupSegGT = goNothing
  where
    goNothing !_ Tip = Nothing
    goNothing x (Bin _ y l r) | (getEnd x) < (getEnd y) = goJust x y l
                              | otherwise = goNothing x r
    goJust !_ best Tip = Just best
    goJust x best (Bin _ y l r) | (getEnd x) < (getEnd y) = goJust x y l
                                | otherwise = goJust x best r

lookupIndexLt :: Segment -> Set Segment -> Int
lookupIndexLt x s = case Set.lookupLE x s of
  Just e -> fromJust $ Set.lookupIndex e s
  Nothing -> 0

lookupIndexGt :: Segment -> Set Segment -> Int
lookupIndexGt x s = case lookupSegGT x s of
  Just e -> 1 + fromJust (Set.lookupIndex e s)
  Nothing -> length s

splitSeg :: Segment -> Set Segment -> (Set Segment, Set Segment, Set Segment)
splitSeg x s = case Set.splitAt (lookupIndexLt x s) s of
  (l, xs) -> case Set.splitAt (lookupIndexGt x xs) xs of
    (overlap, r) -> (l, overlap, r)

notEmpty :: Segment -> Bool
notEmpty (x, y, a, b) = (x /= y) && (a /= 0 || b /= 0)

-- add two segments that intersected
addOrdered :: Segment -> (Segment, [Segment]) -> (Segment, [Segment])
addOrdered  a (b, acc) = case mergeSegment a b of
  (x, y) -> (x, y++acc)

negateSeg :: Segment -> Segment
negateSeg (x, y, a, b) = (x, y, -a, -b)

-- leave the right most part there
mergeSegment :: Segment -> Segment -> (Segment, [Segment])
mergeSegment a@(x1, y1, a1, b1) b@(x2, y2, a2, b2)
  -- a b
  | y1 <= x2 = (a, [b])
  -- b a
  | y2 <= x1 = mergeSegment b a
  -- a contains b
  -- as : bs, bs be; be ae
  | x1 <= x2 && y1 >= y2 = ((x1,x2,a1,b1), [(x2,y2,(x2-x1)*b1+a1+a2,b1+b2),(y2,y1,(y2-x1)*b1+a1,b1)])
  -- b contains a
  | x2 <= x1 && y2 >= y1 = mergeSegment b a
  -- insert a b
  | x1 <= x2 = ((x1,x2,a1,b1), ([(x2, y1, (x2-x1)*b1+a1+a2, b1+b2), (y1,y2,(y1-x2)*b2+a2, b2)]))
  | otherwise = mergeSegment b a

-- maintain none overlapping segments
toSegments :: Int -> Int  -> [Segment]
toSegments x p = [(x-p, x, 0, 1), (x, x + p, p, -1)]

-- find the left end pos, find the right end pos
-- merge all inner segments
addSegment :: Segment -> Set Segment -> Set Segment
addSegment x s = case (splitSeg x s) of
  (l, overlap, r) -> Set.fromAscList $ Set.toAscList l ++ insertSegment x (Set.toAscList overlap) ++ Set.toAscList r
    where
      insertSegment :: Segment -> [Segment] -> [Segment]
      insertSegment s xs =  filter notEmpty $ uncurry (:) $ foldr addOrdered (s, []) xs

-- xs - ys
removeSegments :: Set Segment -> [Segment] -> Set Segment
removeSegments xs ys = foldr subSegment xs ys
  where
    subSegment :: Segment -> Set Segment -> Set Segment
    subSegment s xs = addSegment (negateSeg s) xs

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

getPair :: IO (Int, Int)
getPair = do
  [a, b] <- readChar8
  return (a, b)

printAns :: CoDomain -> IO ()
printAns = putStrLn . showResult

parse :: IO Domain
parse = do
  [n, m] <- readChar8
  xs <- replicateM n getPair
  return (m, xs)

-- solveOne :: Int -> Int -> Int -> [Int] -> Bool
-- solveOne total n m xs = (not (null ks) && (maximum ks) > 2 || even m) && sum ks >= m
--   where ks = filter (>1) $ map (`div` n) xs

getStart :: Segment -> Int
getStart (x, _, _, _) = x

getEnd :: Segment -> Int
getEnd (_, y, _, _) = y

getStartHeight :: Segment -> Int
getStartHeight (_, _, a, _) = a

getEndHeight :: Segment -> Int
getEndHeight (x1, x2, a, b) = a + (x2-x1) * b

getHeight :: Segment -> Int
getHeight s = max (getStartHeight s) (getEndHeight s)

containsPoint :: Int -> (Int, Int) -> Bool
containsPoint x (a,b) = a - b <= x && x <= a + b

getHighest :: Set Segment -> Maybe Segment
getHighest xs = if Set.null xs
  then Nothing
  else Just $ maximumBy (comparing getHeight) $ Set.toAscList  xs

getHeightPos :: Segment -> Int
getHeightPos (x1, x2, _, b)
  | b >= 0 = x2
  | otherwise = x1

-- (Height, height of the position)
computeHighPoint :: Set Segment -> (Int, Int)
computeHighPoint xs = case getHighest xs of
  Just seg -> (getHeight seg,  getHeightPos seg)
  Nothing -> (0, 0)

computeHigh :: Set Segment -> Int
computeHigh = fst . computeHighPoint

-- remove seg, height lower than m after removal
solveOne :: (Int,Int) -> Int -> Set Segment -> (Int, Int) -> Bool
solveOne (height, hightPos) m merged xs = (height <= m) || (containsPoint hightPos xs && (computeHigh $ removeSegments merged $ uncurry toSegments xs) <= m)

showResult :: [Bool] -> String
showResult xs =  map (bool '0' '1') xs

solve :: Solver
solve (m, xs) = result
  where
    mapAcc =  foldl' (\acc (x,y) -> IntMap.unionWith (+) (IntMap.fromList [(x-y, 1), (x, (-2)), (x+y, 1)]) acc) IntMap.empty xs
    heights = tail $ toHeight <$> scanl f (0, 0, 0) (IntMap.toAscList mapAcc)
    highPoints = filter ((> m) . snd) heights
    leftMost = minimum $ (+m) <$> uncurry (-) <$> highPoints
    rightMost = maximum $ (+(-m)) <$> uncurry (+) <$> highPoints
    result = (\(x, y) -> null highPoints || x - y <= leftMost && x + y >= rightMost) <$> xs
    f (pos, ac, height) (nPos, acc) = (nPos, ac + acc, height + (nPos - pos) * ac)
    toHeight (xPos, _, height) = (xPos, height)

solve1 :: Solver
solve1 (m, xs) =
  -- traceShow (m, xs, segments, computeHighPoint merged, ys)
  results
  where
        segments = concatMap (uncurry toSegments) xs
        merged = foldr addSegment Set.empty segments
        (height, hightPos) = computeHighPoint merged
        -- ys = (computeHigh . removeSegments merged . uncurry toSegments) <$> xs
        ys = traceShowId <$> (id &&& computeHigh) <$> (removeSegments merged . uncurry toSegments) <$> xs
        -- containsPointSegments = uncurry toSegments <$> filter (containsPoint hightPos) xs
        results = solveOne (height, hightPos) m merged <$> xs

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

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

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
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)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.Map.Strict 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)
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)

type Domain = (Int, [(Int, Int)])
type CoDomain = [Bool]
type Solver  = Domain -> CoDomain

-- x in a
-- (x, y, a, b)
-- (start x, end x, start y, y per x unit )
type Segment = (Int, Int, Int, Int)

lookupSegGT :: Segment -> Set Segment -> Maybe Segment
lookupSegGT = goNothing
  where
    goNothing !_ Tip = Nothing
    goNothing x (Bin _ y l r) | (getEnd x) < (getEnd y) = goJust x y l
                              | otherwise = goNothing x r
    goJust !_ best Tip = Just best
    goJust x best (Bin _ y l r) | (getEnd x) < (getEnd y) = goJust x y l
                                | otherwise = goJust x best r

lookupIndexLt :: Segment -> Set Segment -> Int
lookupIndexLt x s = case Set.lookupLE x s of
  Just e -> fromJust $ Set.lookupIndex e s
  Nothing -> 0

lookupIndexGt :: Segment -> Set Segment -> Int
lookupIndexGt x s = case lookupSegGT x s of
  Just e -> 1 + fromJust (Set.lookupIndex e s)
  Nothing -> length s

splitSeg :: Segment -> Set Segment -> (Set Segment, Set Segment, Set Segment)
splitSeg x s = case Set.splitAt (lookupIndexLt x s) s of
  (l, xs) -> case Set.splitAt (lookupIndexGt x xs) xs of
    (overlap, r) -> (l, overlap, r)

notEmpty :: Segment -> Bool
notEmpty (x, y, a, b) = (x /= y) && (a /= 0 || b /= 0)

-- add two segments that intersected
addOrdered :: Segment -> (Segment, [Segment]) -> (Segment, [Segment])
addOrdered  a (b, acc) = case mergeSegment a b of
  (x, y) -> (x, y++acc)

negateSeg :: Segment -> Segment
negateSeg (x, y, a, b) = (x, y, -a, -b)

-- leave the right most part there
mergeSegment :: Segment -> Segment -> (Segment, [Segment])
mergeSegment a@(x1, y1, a1, b1) b@(x2, y2, a2, b2)
  -- a b
  | y1 <= x2 = (a, [b])
  -- b a
  | y2 <= x1 = mergeSegment b a
  -- a contains b
  -- as : bs, bs be; be ae
  | x1 <= x2 && y1 >= y2 = ((x1,x2,a1,b1), [(x2,y2,(x2-x1)*b1+a1+a2,b1+b2),(y2,y1,(y2-x1)*b1+a1,b1)])
  -- b contains a
  | x2 <= x1 && y2 >= y1 = mergeSegment b a
  -- insert a b
  | x1 <= x2 = ((x1,x2,a1,b1), ([(x2, y1, (x2-x1)*b1+a1+a2, b1+b2), (y1,y2,(y1-x2)*b2+a2, b2)]))
  | otherwise = mergeSegment b a

-- maintain none overlapping segments
toSegments :: Int -> Int  -> [Segment]
toSegments x p = [(x-p, x, 0, 1), (x, x + p, p, -1)]

-- find the left end pos, find the right end pos
-- merge all inner segments
addSegment :: Segment -> Set Segment -> Set Segment
addSegment x s = case (splitSeg x  s) of
  (l, overlap, r) -> Set.fromAscList $ Set.toAscList l ++ insertSegment x (Set.toAscList overlap) ++ Set.toAscList r
    where
      insertSegment :: Segment -> [Segment] -> [Segment]
      insertSegment s xs =  filter notEmpty $ uncurry (:) $ foldr addOrdered (s, []) xs

-- xs - ys
removeSegments :: Set Segment -> [Segment] -> Set Segment
removeSegments xs ys = foldr subSegment xs ys
  where
    subSegment :: Segment -> Set Segment -> Set Segment
    subSegment s xs = addSegment (negateSeg s) xs

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

getPair :: IO (Int, Int)
getPair = do
  [a, b] <- readChar8
  return (a, b)

printAns :: CoDomain -> IO ()
printAns = putStrLn . showResult

parse :: IO Domain
parse = do
  [n, m] <- readChar8
  xs <- replicateM n getPair
  return (m, xs)

-- solveOne :: Int -> Int -> Int -> [Int] -> Bool
-- solveOne total n m xs = (not (null ks) && (maximum ks) > 2 || even m) && sum ks >= m
--   where ks = filter (>1) $ map (`div` n) xs

getStart :: Segment -> Int
getStart (x, _, _, _) = x

getEnd :: Segment -> Int
getEnd (_, y, _, _) = y

getStartHeight :: Segment -> Int
getStartHeight (_, _, a, _) = a

getEndHeight :: Segment -> Int
getEndHeight (x1, x2, a, b) = a + (x2-x1) * b

getHeight :: Segment -> Int
getHeight s = max (getStartHeight s) (getEndHeight s)

containsPoint :: Int -> (Int, Int) -> Bool
containsPoint x (a,b) = a - b <= x && x <= a + b

getHighest :: Set Segment -> Segment
getHighest xs = maximumBy (comparing getHeight) $ Set.toAscList  xs

getHeightPos :: Segment -> Int
getHeightPos (x1, x2, _, b)
  | b >= 0 = x2
  | otherwise = x1

-- (Height, height of the position)
computeHighPoint :: Set Segment -> (Int, Int)
computeHighPoint xs = (getHeight seg,  getHeightPos seg) where seg = getHighest xs

computeHigh :: Set Segment -> Int
computeHigh = fst . computeHighPoint

-- remove seg, height lower than m after removal
solveOne :: Int -> Int -> Set Segment -> (Int, Int) -> Bool
solveOne hightPoint m merged xs = containsPoint hightPoint xs && (computeHigh $ removeSegments merged $ uncurry toSegments xs) <= m

showResult :: [Bool] -> String
showResult xs =  map (bool '0' '1') xs

solve :: Solver
solve (m, xs) =
  -- traceShow (xs, segments, computeHighPoint merged, ys)
  results
  where
        segments = concatMap (uncurry toSegments) xs
        merged = foldr addSegment Set.empty segments
        hightPos = snd $ computeHighPoint merged
        -- ys = (computeHigh . removeSegments merged . uncurry toSegments) <$> xs
        -- ys = traceShowId <$> (id &&& computeHigh) <$> (removeSegments merged . uncurry toSegments) <$> xs
        -- containsPointSegments = uncurry toSegments <$> filter (containsPoint hightPos) xs
        results = solveOne hightPos m merged <$> xs

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

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

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
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)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.Map.Strict 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)
import Control.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)

type Domain = (Int, [(Int, Int)])
type CoDomain = [Bool]
type Solver  = Domain -> CoDomain

-- x in a
-- (x, y, a, b)
-- (start x, end x, start y, y per x unit )
type Segment = (Int, Int, Int, Int)

lookupSegGT :: Segment -> Set Segment -> Maybe Segment
lookupSegGT = goNothing
  where
    goNothing !_ Tip = Nothing
    goNothing x (Bin _ y l r) | (getEnd x) < (getEnd y) = goJust x y l
                              | otherwise = goNothing x r
    goJust !_ best Tip = Just best
    goJust x best (Bin _ y l r) | (getEnd x) < (getEnd y) = goJust x y l
                                | otherwise = goJust x best r

lookupIndexLt :: Segment -> Set Segment -> Int
lookupIndexLt x s = case Set.lookupLE x s of
  Just e -> fromJust $ Set.lookupIndex e s
  Nothing -> 0

lookupIndexGt :: Segment -> Set Segment -> Int
lookupIndexGt x s = case lookupSegGT x s of
  Just e -> 1 + fromJust (Set.lookupIndex e s)
  Nothing -> length s

splitSeg :: Segment -> Set Segment -> (Set Segment, Set Segment, Set Segment)
splitSeg x s = case Set.splitAt (lookupIndexLt x s) s of
  (l, xs) -> case Set.splitAt (lookupIndexGt x xs) xs of
    (overlap, r) -> (l, overlap, r)

notEmpty :: Segment -> Bool
notEmpty (x, y, _, _) = not $ x == y

-- add two segments that intersected
addOrdered :: Segment -> (Segment, [Segment]) -> (Segment, [Segment])
addOrdered  a (b, acc) = case mergeSegment a b of
  (x, y) -> (x, y++acc)

negateSeg :: Segment -> Segment
negateSeg (x, y, a, b) = (x, y, -a, -b)

-- leave the right most part there
mergeSegment :: Segment -> Segment -> (Segment, [Segment])
mergeSegment a@(x1, y1, a1, b1) b@(x2, y2, a2, b2)
  -- a b
  | y1 <= x2 = (a, [b])
  -- b a
  | y2 <= x1 = mergeSegment b a
  -- a contains b
  -- as : bs, bs be; be ae
  | x1 <= x2 && y1 >= y2 = ((x1,x2,a1,b1), [(x2,y2,(x2-x1)*b1+a1+a2,b1+b2),(y2,y1,(y2-x1)*b1+a1,b1)])
  -- b contains a
  | x2 <= x1 && y2 >= y1 = mergeSegment b a
  -- insert a b
  | x1 <= x2 = ((x1,x2,a1,b1), ([(x2, y1, (x2-x1)*b1+a1+a2, b1+b2), (y1,y2,(y1-x2)*b2+a2, b2)]))
  | otherwise = mergeSegment b a

-- maintain none overlapping segments
toSegments :: Int -> Int  -> [Segment]
toSegments x p = [(x-p, x, 0, 1), (x, x + p, p, -1)]

-- find the left end pos, find the right end pos
-- merge all inner segments
addSegment :: Segment -> Set Segment -> Set Segment
addSegment x s = case (splitSeg x  s) of
  (l, overlap, r) -> Set.fromAscList $ Set.toAscList l ++ insertSegment x (Set.toAscList overlap) ++ Set.toAscList r
    where
      insertSegment :: Segment -> [Segment] -> [Segment]
      insertSegment s xs =  filter notEmpty $ uncurry (:) $ foldr addOrdered (s, []) xs

-- xs - ys
removeSegments :: Set Segment -> [Segment] -> Set Segment
removeSegments xs ys = foldr subSegment xs ys
  where
    subSegment :: Segment -> Set Segment -> Set Segment
    subSegment s xs = addSegment (negateSeg s) xs

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

getPair :: IO (Int, Int)
getPair = do
  [a, b] <- readChar8
  return (a, b)

printAns :: CoDomain -> IO ()
printAns = putStrLn . showResult

parse :: IO Domain
parse = do
  [n, m] <- readChar8
  xs <- replicateM n getPair
  return (m, xs)

-- solveOne :: Int -> Int -> Int -> [Int] -> Bool
-- solveOne total n m xs = (not (null ks) && (maximum ks) > 2 || even m) && sum ks >= m
--   where ks = filter (>1) $ map (`div` n) xs

getStart :: Segment -> Int
getStart (x, _, _, _) = x

getEnd :: Segment -> Int
getEnd (_, y, _, _) = y

getStartHeight :: Segment -> Int
getStartHeight (_, _, a, _) = a

getEndHeight :: Segment -> Int
getEndHeight (x1, x2, a, b) = a + (x2-x1) * b

getHeight :: Segment -> Int
getHeight s = max (getStartHeight s) (getEndHeight s)

containsPoint :: Int -> (Int, Int) -> Bool
containsPoint x (a,b) = a - b <= x && x <= a + b

getHighest :: Set Segment -> Segment
getHighest xs = maximumBy (comparing getHeight) $ Set.toAscList  xs

getHeightPos :: Segment -> Int
getHeightPos (x1, x2, _, b)
  | b >= 0 = x2
  | otherwise = x1

-- (Height, height of the position)
computeHighPoint :: Set Segment -> (Int, Int)
computeHighPoint xs = (getHeight seg,  getHeightPos seg) where seg = getHighest xs

computeHigh :: Set Segment -> Int
computeHigh = fst . computeHighPoint

-- remove seg, height lower than m
solveOne :: Int -> Int -> Set Segment -> (Int, Int) -> Bool
solveOne hightPoint m merged xs = containsPoint hightPoint xs && (computeHigh $ removeSegments merged $ uncurry toSegments xs) > m

showResult :: [Bool] -> String
showResult xs =  map (bool '1' '0') xs

solve :: Solver
solve (m, xs) = results -- ++ show xs ++ ":" -- ++ show containsPointSegments
  where
        merged = foldr addSegment Set.empty (concatMap (uncurry toSegments) xs)
        hightPoint = snd $ computeHighPoint merged
        containsPointSegments = uncurry toSegments <$> filter (containsPoint hightPoint) xs
        results = solveOne hightPoint m merged <$> xs

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


While trading on his favorite exchange trader William realized that he found a vulnerability. Using this vulnerability he could change the values of certain internal variables to his advantage. To play around he decided to change the values of all internal variables from $$$a_1, a_2, \ldots, a_n$$$ to $$$-a_1, -a_2, \ldots, -a_n$$$. For some unknown reason, the number of service variables is always an even number.William understands that with his every action he attracts more and more attention from the exchange's security team, so the number of his actions must not exceed $$$5\,000$$$ and after every operation no variable can have an absolute value greater than $$$10^{18}$$$. William can perform actions of two types for two chosen variables with indices $$$i$$$ and $$$j$$$, where $$$i < j$$$:  Perform assignment $$$a_i = a_i + a_j$$$  Perform assignment $$$a_j = a_j - a_i$$$  William wants you to develop a strategy that will get all the internal variables to the desired values.

Each test contains multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \le t \le 20$$$). Description of the test cases follows. The first line of each test case contains a single even integer $$$n$$$ ($$$2 \le n \le 10^3$$$), which is the number of internal variables. The second line of each test case contains $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$ $$$(1 \le a_i \le 10^9)$$$, which are initial values of internal variables.

For each test case print the answer in the following format: The first line of output must contain the total number of actions $$$k$$$, which the strategy will perform. Note that you do not have to minimize $$$k$$$. The inequality $$$k \le 5\,000$$$ must be satisfied.  Each of the next $$$k$$$ lines must contain actions formatted as "type i j", where "type" is equal to "1" if the strategy needs to perform an assignment of the first type and "2" if the strategy needs to perform an assignment of the second type. Note that $$$i < j$$$ should hold. We can show that an answer always exists.

NoteFor the first sample test case one possible sequence of operations is as follows:  "2 1 2". Values of variables after performing the operation: [1, 0, 1, 1]  "2 1 2". Values of variables after performing the operation: [1, -1, 1, 1]  "2 1 3". Values of variables after performing the operation: [1, -1, 0, 1]  "2 1 3". Values of variables after performing the operation: [1, -1, -1, 1]  "2 1 4". Values of variables after performing the operation: [1, -1, -1, 0]  "2 1 4". Values of variables after performing the operation: [1, -1, -1, -1]  "1 1 2". Values of variables after performing the operation: [0, -1, -1, -1]  "1 1 2". Values of variables after performing the operation: [-1, -1, -1, -1] For the second sample test case one possible sequence of operations is as follows:  "2 1 4". Values of variables after performing the operation: [4, 3, 1, -2]  "1 2 4". Values of variables after performing the operation: [4, 1, 1, -2]  "1 2 4". Values of variables after performing the operation: [4, -1, 1, -2]  "1 2 4". Values of variables after performing the operation: [4, -3, 1, -2]  "1 3 4". Values of variables after performing the operation: [4, -3, -1, -2]  "1 1 2". Values of variables after performing the operation: [1, -3, -1, -2]  "1 1 2". Values of variables after performing the operation: [-2, -3, -1, -2]  "1 1 4". Values of variables after performing the operation: [-4, -3, -1, -2]

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

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

getInts :: IO [Int]
getInts = map parseInt . C.words <$> C.getLine

main :: IO ()
main = do
  [t] <- getInts
  output <- fmap mconcat $ replicateM t $ do
    [n] <- getInts
    _ <- C.getLine
    let f j i = intDec j `mappend` charUtf8 ' ' `mappend` intDec (2 * i - 1) `mappend` charUtf8 ' ' `mappend` intDec (2 * i) `mappend` charUtf8 '\n'
        func i = f 1 i `mappend` f 2 i `mappend` f 1 i `mappend` f 2 i `mappend` f 1 i `mappend` f 2 i
        result = mconcat [func i | i <- [1 .. n `div` 2]]
    return $ intDec (3 * n) `mappend` charUtf8 '\n' `mappend` result
  hPutBuilder stdout output

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Builder as B
import System.IO

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Data.List
import Data.Semigroup

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [t] <- readInts
  replicateM_ t $ do
    [n] <- readInts
    _a <- readInts
    let
      n2 = div n 2
    putInts [n2 * 6]
    forM_ [1 .. n2] $ \iv -> replicateM_ 2 $ do
      putInts [1, iv*2 - 1, iv*2]
      putInts [2, iv*2 - 1, iv*2]
      putInts [1, iv*2 - 1, iv*2]

type SIO = StateT P.ByteString IO

readLine :: SIO P.ByteString
readLine = do
  (out, next) <- P.break (<= '\r') <$> get
  put $ P.dropWhile (<= '\r') next
  pure out

readInts :: SIO [Int]
readInts = do
  currLine <- readLine
  pure [x | Just (x, _) <- P.readInt <$> P.words currLine]

putInts :: [Int] -> SIO ()
putInts li = let
  outBuilder = foldr (<>) (B.char7 '\n')
    $ intersperse (B.char7 ' ') (map B.intDec li)
  in  lift $ B.hPutBuilder stdout outBuilder


Fillomino is a classic logic puzzle. (You do not need to know Fillomino in order to solve this problem.) In one classroom in Yunqi town, some volunteers are playing a board game variant of it:Consider an $$$n$$$ by $$$n$$$ chessboard. Its rows are numbered from $$$1$$$ to $$$n$$$ from the top to the bottom. Its columns are numbered from $$$1$$$ to $$$n$$$ from the left to the right. A cell on an intersection of $$$x$$$-th row and $$$y$$$-th column is denoted $$$(x, y)$$$. The main diagonal of the chessboard is cells $$$(x, x)$$$ for all $$$1 \le x \le n$$$.A permutation of $$$\{1, 2, 3, \dots, n\}$$$ is written on the main diagonal of the chessboard. There is exactly one number written on each of the cells. The problem is to partition the cells under and on the main diagonal (there are exactly $$$1+2+ \ldots +n$$$ such cells) into $$$n$$$ connected regions satisfying the following constraints:  Every region should be connected. That means that we can move from any cell of a region to any other cell of the same region visiting only cells of the same region and moving from a cell to an adjacent cell.  The $$$x$$$-th region should contain cell on the main diagonal with number $$$x$$$ for all $$$1\le x\le n$$$.  The number of cells that belong to the $$$x$$$-th region should be equal to $$$x$$$ for all $$$1\le x\le n$$$.  Each cell under and on the main diagonal should belong to exactly one region.

The first line contains a single integer $$$n$$$ ($$$1\le n \le 500$$$) denoting the size of the chessboard. The second line contains $$$n$$$ integers $$$p_1$$$, $$$p_2$$$, ..., $$$p_n$$$. $$$p_i$$$ is the number written on cell $$$(i, i)$$$. It is guaranteed that each integer from $$$\{1, \ldots, n\}$$$ appears exactly once in $$$p_1$$$, ..., $$$p_n$$$.

If no solution exists, output $$$-1$$$. Otherwise, output $$$n$$$ lines. The $$$i$$$-th line should contain $$$i$$$ numbers. The $$$j$$$-th number on the $$$i$$$-th line should be $$$x$$$ if cell $$$(i, j)$$$ belongs to the the region with $$$x$$$ cells.

NoteThe solutions to the examples are illustrated in the following pictures:

import Data.Maybe
import Data.List
import qualified Data.ByteString.Char8 as C
import Data.ByteString.Builder
import System.IO

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

getInts :: IO [Int]
getInts = map parseInt . C.words <$> C.getLine

putInts :: [Int] -> Builder
putInts xs = (mconcat $ intersperse (charUtf8 ' ') $ map intDec xs) `mappend` (charUtf8 '\n')

main :: IO ()
main = do
  [n] <- getInts
  ps <- getInts
  let ps' = scanl' acc ps [1..n-1]
        where acc xs t = filter (/= t) xs
      transform cnt pss
        | cnt > n = []
        | otherwise = reverse (map head as) : transform (cnt + 1) (map tail as ++ bs)
        where (as, bs) = splitAt cnt pss
      output = mconcat $ map putInts $ transform 1 ps'
  hPutBuilder stdout output

{-# OPTIONS_GHC -O2 #-}

import Control.Monad
import Prelude as P

import Data.Word (Word8)
import Data.Int (Int64)
import qualified Data.Bits as Bits
import qualified Data.Char as Char

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

import qualified Data.ByteString as Bs
import qualified System.IO as Io
--import Data.IntSet

fill :: Map.Map (Int, Int) Int -> Int -> Int -> Int -> Int -> Int -> Map.Map (Int, Int) Int
fill m xmax cnt a x y
  | cnt == 1 && not memb = newmap
  | left = if memb then fill m xmax cnt a x (y-1) else fill newmap xmax (cnt-1) a x (y-1)
  | down = if memb then fill m xmax cnt a (x+1) y else fill newmap xmax (cnt-1) a (x+1) y
  | right = if memb then fill m xmax cnt a x (y+1) else fill newmap xmax (cnt-1) a x (y+1)
  | otherwise = error "nowhere to go"
  where memb = Map.member (x, y) m
        left = y > 1 && Map.notMember (x, y-1) m
        right = y < x && Map.notMember (x, y+1) m
        down = x < xmax && Map.notMember (x+1, y) m
        newmap = Map.insert (x, y) a m

solve :: IO ()
solve = do
  n <- readLn :: IO Int
  xs <- readInts :: IO [Int]
  let res = foldl (\m (x, i) -> fill m n x x i i) Map.empty $ zip xs [1..n]
      lines = [zip (repeat i) [1..i] |  i <- [1..n]]
      sol = intercalate "\n" $ map (intercalate " " . map (\k -> show . Map.findWithDefault 0 k $ res)) lines
    in putStrLn sol

main = do
  let t = 1
  replicateM_ t $ solve

----------------------------------------------------------------------------------------
readrows :: (Integral a, Integral b) => b -> IO [[a]]
readrows 0 = return []
readrows n = do
  row <- readInts
  l <- readrows $ n-1
  return (row : l)

parseInt :: (Integral a) => Bs.ByteString -> a
parseInt xs = snd $ Bs.foldr (\y (pow, acc) -> (pow*10, acc + pow*(fromIntegral (y-48)))) (1, 0) xs

readInts :: (Integral a) => IO [a]
readInts =  map parseInt . filter (/=Bs.empty) . Bs.splitWith (==32) . fuckingWindowsCRLF <$> Bs.getLine
  where fuckingWindowsCRLF bs = if Bs.last bs == 13 then Bs.init bs else bs

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

import qualified Data.Array as A

import Data.Bits(xor)

import Data.Array((!))
import Control.Monad(replicateM)

import Data.Maybe

solve :: Integer -> [Integer] -> [[Integer]]
solve 1 [1] = [[1]]
solve 1 _ = error "impossile"

solve 2 [1, 2] = [[1], [2, 2]]
solve 2 [2, 1] = [[2], [2, 1]]
solve 2 _ = error "impossible"

solve n diag = [diag !! 0] : fmap (\(i, j) -> (fmap (+1) j)++[i]) (zip (tail diag) solution) where
	solution = solve (n-1) $ fmap (\i->i-1) $ filter (/=1) diag

showR :: [[Integer]] -> String
showR (x:xs) = foldr (\i s->show i ++ " " ++ s) "\n" x ++ showR xs
showR [] = []

main = do
	let t = 1 -- t <- getLine >>= return . read :: IO Int
	replicateM t $ do
		[n] <- getLine >>= return . (fmap read) . words :: IO [Integer]
		diag <- getLine >>= return . (fmap read) . words :: IO [Integer]
		putStr $ showR $ solve n diag


Recently, Norge found a string $$$s = s_1 s_2 \ldots s_n$$$ consisting of $$$n$$$ lowercase Latin letters. As an exercise to improve his typing speed, he decided to type all substrings of the string $$$s$$$. Yes, all $$$\frac{n (n + 1)}{2}$$$ of them!A substring of $$$s$$$ is a non-empty string $$$x = s[a \ldots b] = s_{a} s_{a + 1} \ldots s_{b}$$$ ($$$1 \leq a \leq b \leq n$$$). For example, "auto" and "ton" are substrings of "automaton".Shortly after the start of the exercise, Norge realized that his keyboard was broken, namely, he could use only $$$k$$$ Latin letters $$$c_1, c_2, \ldots, c_k$$$ out of $$$26$$$.After that, Norge became interested in how many substrings of the string $$$s$$$ he could still type using his broken keyboard. Help him to find this number.

The first line contains two space-separated integers $$$n$$$ and $$$k$$$ ($$$1 \leq n \leq 2 \cdot 10^5$$$, $$$1 \leq k \leq 26$$$) — the length of the string $$$s$$$ and the number of Latin letters still available on the keyboard. The second line contains the string $$$s$$$ consisting of exactly $$$n$$$ lowercase Latin letters. The third line contains $$$k$$$ space-separated distinct lowercase Latin letters $$$c_1, c_2, \ldots, c_k$$$ — the letters still available on the keyboard.

Print a single number — the number of substrings of $$$s$$$ that can be typed using only available letters $$$c_1, c_2, \ldots, c_k$$$.

import Control.Monad

solve :: String -> [Char] -> [Integer]
solve inp  l =uncurry (:) (foldl f (0,[]) inp )
  where
    f (count,list) char
      |char `elem` l = (count+1,list)
      |otherwise = (0,count:list)

c :: [Integer] -> Integer
c =sum. map (\x -> x*(x+1) `div` 2)

routine :: IO ()
routine = do
  _ <- getLine
  m <- getLine
  l <- (concat.words) <$>getLine
  print $ c $  solve m l

main :: IO ()
main = do
  routine

main :: IO ()
main = getLine >> f <$> input >>= print
  where f (s, d) = solve d s

type Dict = String

input :: IO (String, Dict)
input = (,) <$> getLine <*> fmap (mconcat . words) getLine

nextToken :: Dict -> String -> (String, String)
nextToken dict = span pred . dropUntil pred
  where pred = (`elem` dict)
        dropUntil p = dropWhile $ not . p

solve :: Dict -> String -> Integer
solve _ [] = 0
solve dict s = f (fromIntegral $ length t) + solve dict r
  where (t, r) = nextToken dict s
        f l = (l + 1) * l `div` 2

import qualified Data.Set as S

getChunksSizes :: String -> S.Set Char -> [Int]
getChunksSizes xs set = go xs 0 where
    go [] acc = [acc]
    go (x : xs) acc =
        if S.member x set then acc : go xs 0
        else go xs (acc + 1)

summation :: Int -> Integer
summation n = x*(x + 1) `div` 2 where
    x = toInteger n

getNumSubs :: String -> S.Set Char -> Integer
getNumSubs xs keys = foldl (+) 0 $ map summation (getChunksSizes xs keys)

getMissingKeys :: String -> String ->  S.Set Char
getMissingKeys xs keys = S.difference setXs setKeys where
    setXs = S.fromList xs
    setKeys = S.fromList keys

main =
    getLine >> getLine >>= \xs ->
    concat . words <$> getLine >>= \keys ->
    print $ getNumSubs xs (getMissingKeys xs keys)

import Control.Monad

solve :: String -> [Char] -> [Int]
solve inp  l =uncurry (:) (foldl f (0,[]) inp )
  where
    f (count,list) char
      |char `elem` l = (count+1,list)
      |otherwise = (0,count:list)

c :: [Int] -> Int
c =sum. map (\x -> x*(x+1) `div` 2)

routine :: IO ()
routine = do
  _ <- getLine
  m <- getLine
  l <- (concat.words) <$>getLine
  print $ c $  solve m l

main :: IO ()
main = do
  routine

main :: IO ()
main = getLine >> f <$> input >>= print
  where f (s, d) = solve d s

type Dict = String

input :: IO (String, Dict)
input = (,) <$> getLine <*> fmap (mconcat . words) getLine

nextToken :: Dict -> String -> (String, String)
nextToken dict = span pred . dropUntil pred
  where pred = (`elem` dict)
        dropUntil p = dropWhile $ not . p

solve :: Dict -> String -> Int
solve _ [] = 0
solve dict s = f (length t) + solve dict r
  where (t, r) = nextToken dict s
        f l = (l + 1) * l `div` 2

import qualified Data.Set as S

getChunksSizes :: String -> S.Set Char -> [Int]
getChunksSizes xs set = go xs 0 where
    go [] acc = [acc]
    go (x : xs) acc =
        if S.member x set then acc : go xs 0
        else go xs (acc + 1)

summation :: Int -> Int
summation n = n*(n + 1) `div` 2

getNumSubs :: String -> S.Set Char -> Int
getNumSubs xs keys = foldl (+) 0 $ map summation (getChunksSizes xs keys)

getMissingKeys :: String -> String ->  S.Set Char
getMissingKeys xs keys = S.difference setXs setKeys where
    setXs = S.fromList xs
    setKeys = S.fromList keys

main =
    getLine >> getLine >>= \xs ->
    concat . words <$> getLine >>= \keys ->
    print $ getNumSubs xs (getMissingKeys xs keys)