One day three best friends Petya, Vasya and Tonya decided to form a team and take part in programming contests. Participants are usually offered several problems during programming contests. Long before the start the friends decided that they will implement a problem if at least two of them are sure about the solution. Otherwise, the friends won't write the problem's solution.This contest offers n problems to the participants. For each problem we know, which friend is sure about the solution. Help the friends find the number of problems for which they will write a solution.

The first input line contains a single integer n (1 ≤ n ≤ 1000) — the number of problems in the contest. Then n lines contain three integers each, each integer is either 0 or 1. If the first number in the line equals 1, then Petya is sure about the problem's solution, otherwise he isn't sure. The second number shows Vasya's view on the solution, the third number shows Tonya's view. The numbers on the lines are separated by spaces.

Print a single integer — the number of problems the friends will implement on the contest.

NoteIn the first sample Petya and Vasya are sure that they know how to solve the first problem and all three of them know how to solve the second problem. That means that they will write solutions for these problems. Only Petya is sure about the solution for the third problem, but that isn't enough, so the friends won't take it. In the second sample the friends will only implement the second problem, as Vasya and Tonya are sure about the solution.

main = do
	dat <- getContents
	let allLines = tail $ lines dat
	putStrLn $ show $ answer allLines

answer :: [String] -> Int
answer = length . filter (\x -> x == "1 1 1" || x == "1 1 0" || x == "1 0 1" || x == "0 1 1")

cYcle 0 m=do
	putStr $ show m
cYcle n m=do
    input<-getLine
    let t = words input
    let a = read (head t)
    let b = read (head (tail t))
    let c = read (head (tail (tail t)))
    let p = if a+b+c>1 then m+1 else m
    cYcle (n-1) p
main=do
    input<-getLine
    cYcle (read.head.words$input) 0

{-# LANGUAGE OverloadedStrings #-}

import Control.Monad.State
import Control.Monad.Writer.Strict (liftM, replicateM_)
import qualified Data.ByteString.Char8 as C

main = do
  n <- read `fmap` getLine :: IO Int
  r <-
    replicateM n $ do
      q <- C.getLine
      let qs = fmap trim . (C.split ' ') $ q
      if (foldl score 0 qs) >= 2
        then return 1
        else return 0
  putStrLn . show . sum $ r

score :: Int -> C.ByteString -> Int
score s "1" = s + 1
score s _ = s

trim :: C.ByteString -> C.ByteString
trim s = C.filter (\c -> (||) (c == '1') (c == '0')) s

-- Michael V. Antosha  <Michael.Antosha@gmail.com>
-- 2016
-- http://mivael.in.ua

main = do
  interact $ show . s . map read . words
    where
      s (n:triples) = csum n triples
      s _ = error "N expected."

      csum 0 [] = 0
      csum n (a:b:c:rest) =
        (count (a+b+c >= 2)) + (csum (n-1) rest)
      csum _ _ = error "N triples expected."

      count True = 1
      count False = 0

{-#LANGUAGE OverloadedStrings#-}
module Main where

import Data.Text (splitOn, pack, unpack)

main :: IO ()
main = do
    [n] <- getInts
    solve n
    >>= pure . length . filter (>=2)
    >>= putStrLn . show

-- solve :: Int -> String
-- solve = undefined

solve ::  Int -> IO [Int]
solve n = sequence [getLine >>= oz | _ <- [1..n]]

-- ones should be greater than equal to 2
oz :: String -> IO Int
oz  = pure . length . filter (=='1')

getInts :: IO [Int]
getInts = fmap ( map ( read . unpack )
            . splitOn " " . pack ) getLine

main = do
	n<-getLine
	a<-getContents
	let k =map words $ lines a
	putStrLn $ show $ sum $ map (solve.map read) k

solve k = if length ( filter (==1) k) >=2 then 1
	      else 0

solve x = show . sum . map (check . map read . words) $ (drop 1 $ lines x)
          where check x = if sum x > 1 then 1 else 0

main = interact solve

module Main where

(|>) = flip (.)

main = interact $
    lines
    |> drop 1
    |> map (words |> map read)
    |> map sum
    |> filter (>= 2)
    |> length
    |> show

import Data.Char
import System.IO

getWords :: String -> [String]
getWords str = words str

lineProc :: String -> [Integer]
lineProc str = map readInt (getWords(str))
	where readInt = read :: String -> Integer

sumAll :: [Integer] -> Integer
sumAll lst = sum lst

invoke :: Integer -> IO Integer
invoke n = if n == 0 then return $ 0 else do
	new_line <- getLine
	to_add <- invoke(n - 1)
	return $ (if (sumAll $ lineProc $ new_line) >= 2 then 1 else 0) + to_add

main = do
	n <- getLine
	result <- invoke (read n :: Integer)
	print $ result

solve :: String -> Integer
solve all =
    let
      conv = map (map (read::String->Integer)) $ map words .tail $ lines all
    in foldl (\acc x -> if x > 1 then acc + 1 else acc) 0 $ map sum conv
main = do
    all <- getContents
    print $ solve all

module Main where

import Control.Applicative

getL n = sequence (replicate n getLine)

main = do
  n <- getLine
  l <- map (length . filter (=='1')) <$> lines <$> getContents
  putStrLn $ show . length . filter (>=2) $ l

main = readsolveprint
readsolveprint::IO()
readsolveprint =  getLine >>= \x-> interact $ show.foldr (\a b-> case () of
                                                                    _|a> 1 ->  1+b
                                                                     |otherwise -> b ) 0. map (foldr (\a b-> read a+b) 0. words). take (read x) . lines

module Main where
import Control.Applicative
import Control.Monad
main = do
  problems <- ((read :: String -> Int) <$> getLine) >>= \c -> mapM (\_ -> getLine) [1..c]
  print $ length $ filter (\p -> (length $ filter (=='1') p) >1 ) problems

import Control.Monad
main = do
    taskCount <- getLine
    res <- forM [1..read taskCount] (\_ -> do
        strTask <- getLine
        let [a,b,c] = map read . words $ strTask
        return $ if a+b+c >= 2 then 1 else 0)
    print $ sum res

answer :: [[Int]] -> Int
answer = length . filter (>=2) . map sum

main = do interact $ show . answer . map (map read) . map words . tail . lines

module Main where

import Control.Monad (replicateM)

main :: IO ()
main = do
  n <- fmap read getLine :: IO Int
  inp <- replicateM n getLine
  let willSolve = fmap (length . filter (== '1')) inp
      output = length . filter (> 1) $ willSolve
  print output

main =
  print .
  length .
  filter (>1) .
  map (sum . map read . words) .
  tail .
  lines =<< getContents

import Data.List
import Data.List.Split
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Char as C

(|>) = flip ($)

main = interact process

process contents = let
  problems = contents |> lines |> tail |> map words |> map (map read) :: [[Int]]
  in solve problems |> show

solve problems = problems
  |> map sum
  |> filter (>= 2)
  |> length

main = do
    getLine
    interact (solve.(map (map read)).(map words).lines)
solve = show.(result 0)
result acc x
    |x==[]              = acc
    |sum(head x)>=2     = result (acc+1) (tail x)
    |otherwise          = result acc (tail x)

import Data.List
import Control.Applicative

solve :: [Int] -> Bool
solve = (>= 2) . length . filter ((==) 1)

main = do
  (_:cases) <- fmap (fmap read) . fmap words . lines <$> getContents
  let n = length $ filter id $ fmap solve cases
  print n

import Control.Monad

-- Snippet: readInts
readInts = do
    line <- getLine
    return $ map read $ words line

main = do
    n <- readLn
    answer <- replicateM n $ do
        s <- readInts
        return $ if sum s < 2 then 0 else 1
    putStrLn $ show $ sum answer

solve :: String -> Int
solve xs
    | s > 1 = 1
    | otherwise = 0
    where s = sum (map read (words xs))

main = interact $ show . sum . map solve . tail . lines

module Main where

infixl 0 |>
x |> f = f x

getInt :: IO Int
getInt = readLn

process :: (Eq t, Num t) => t -> [Int] -> IO [Int]
process 0     sums = return sums
process range sums = do
  line <- getLine
  let currentSum = line |> words |> map (read :: String -> Int) |> sum
  process (range - 1) (currentSum : sums)

main :: IO ()
main = do
  range         <- getInt
  processedSums <- process range []
  processedSums |> filter (>= 2) |> length |> print

import Control.Monad

main = do
    n <- getLine
    inputs <- replicateM (read n) (getLine)
    print $ parseInputs inputs

parseInputs []   = 0
parseInputs (x:xs)
    | (sum (map read (words x))) > 1 = 1 + parseInputs xs
    | otherwise = parseInputs xs

import Data.List
import Control.Applicative

solve :: [Int] -> Bool
solve = (>= 2) . length . filter ((==) 1)

main = do
  (_:cases) <- fmap (fmap read) . fmap words . lines <$> getContents
  let n = length $ filter solve cases
  print n

-- cf 231 a

main :: IO ()
main = getContents >>= (print . f 0 . map (map read . words) . tail . lines)

f :: Int -> [[Integer]]-> Int
f acc [] = acc
f acc (x : rem)
  | sum x > 1 = f (acc+1) rem
  | otherwise = f acc rem

-- Vicfred
-- https://codeforces.com/problemset/problem/231/A

import Control.Monad

main = do
    n <- readLn
    a <- replicateM n getList
    putStrLn . show $ solve a

solve :: [[Int]] -> Int
solve = length . filter ((>= 2) . sum)

getList :: Read a => IO [a]
getList = fmap (map read . words) getLine

main :: IO ()
main = getContents >>= print . solve . map (map read . words) . tail . lines

solve :: [[Int]] -> Int
solve = length . filter ((>1) . sum)

solve [] = 0
solve ((a, b, c):xs) = if a + b + c > 1 then y + 1 else y where y = solve xs

main :: IO()
main = do
    n <- getLine
    contents <- getContents
    let input = map ((\(a:b:c:_) -> (a, b, c)) . map (read :: String -> Int) . words) $ lines contents
    print(solve input)

import Control.Applicative

main::IO ()
main=do
    getLine
    a<-(map (map read.words)) .lines <$> getContents
    print $ length $ filter (>1) $ map sum a

main = interact $ show . length . filter (>= 2) .  map (length . filter (== "1") . words) . tail . lines

import Control.Applicative
import Control.Monad

main = do
  n <- read <$> getLine
  ls <- map (map read . words) <$> replicateM n getLine :: IO [[Int]]
  let nt = sum $ map (`cntOnes` 0) ls
  print nt

cntOnes [] c = 0
cntOnes (x:xs) c
  | c+x > 1     = 1
  | otherwise = cntOnes xs (c+x)

module Main where
import Data.List

solve :: Integer -> [Integer] -> Integer
solve acc xs = acc + (if s >= 2 then 1 else 0)
               where s = foldl1' (+) xs

main = interact $ show . (foldl' solve 0) .  (map (map read)) . (map words) . (drop 1) . lines

module Main where

--71A
--replicateM n x = sequence (replicate n x)

--processWord :: String -> String
--processWord word | length word > 10 = (head word) : (show (length word - 2)) ++ ((last word):[])--(word !! ((length word) - 1))
--                 | otherwise = word

--main = sequence [putStrLn $ show i | i <- [1..5]]
--main = getLine >>= \line -> replicateM (read line) (getLine) >>= \list -> sequence [putStrLn (processWord (list!!i)) | i <- [0..(length list) - 1]]

--118A
--import Data.Char
--isSylable :: Char -> Bool
--isSylable char = elem char "AOYEUIaoyeui"
--
--deleteSylabls::[Char] -> [Char]
--deleteSylabls [] = []
--deleteSylabls (x:xs) | isSylable x = deleteSylabls xs
--                     | otherwise = x:(deleteSylabls xs)
--
--addDots :: [Char] -> [Char]
--addDots [] = []
--addDots (x:xs) = '.' : x : (addDots xs)
--
--processWord :: String -> String
--processWord = addDots . deleteSylabls . (map toLower)
--
--main = getLine >>= putStrLn . processWord

--50A

--split :: Char -> String -> [String]
--split _ [] = [""]
--split c (x:xs) | x == c = "" : rest
--               | otherwise = (x : head rest): tail rest
--                where rest = split c xs
--
--calc :: Int -> Int -> Int
--calc  m n = m*n `div` 2
--
--main = getLine >>= \a -> let inp = (map read (split  ' ' a)) in putStrLn $ show $ calc (inp !! 0) (inp !! 1)

--231A

split :: Char -> String -> [String]
split _ [] = [""]
split c (x:xs) | x == c = "" : rest
               | otherwise = (x : head rest): tail rest
                where rest = split c xs

isGood :: [Int] -> Int
isGood (a:b:c:[]) = if (a+b+c >= 2) then 1 else 0

toIntList :: [[String]] -> [[Int]]
toIntList strs = map (map read) strs

main = getLine >>= \line -> sequence (replicate (read line) getLine) >>= \list -> putStrLn $ show $ sum $ map isGood (toIntList (map (split ' ') list))

-- import Data.Char
-- import Data.Int
-- import Data.List
import Control.Monad
getList :: Read a => IO [a]
getList = fmap (map read . words) getLine

solve :: [[Int]] -> Int
solve = length . filter ((>= 2) . sum)

main :: IO ()
main = do
        n <- readLn
        a <- replicateM n getList
        putStrLn . show $ solve a

f::[String]->Int
f []=0
f (x:xs)=let ys=map read (words x)::[Int]
             y=sum ys
         in if y>1 then 1+f xs else f xs

main =do
      e<-getLine
      es<-getContents
      let xs=lines es
      print $ f xs

import Prelude hiding (catch)
import Control.Applicative
import Control.Exception

readLines :: Int -> IO [String]
readLines 0 = return [""]
readLines n = do
        s <- getLine
        rest <- readLines (n - 1)
        return $ s:rest

calc :: String -> Int
calc s = if (sum $ map read $ words s) >= 2 then 1 else 0

main = do
    n <- read <$> getLine
    ss <- readLines n
    print $ sum $ map calc ss

main = interact $ show . length . filter (> 1) . map (sum . map read . words) . tail . lines

import Control.Monad

main = interact program

program :: String -> String
program input =
    let _:ts = lines input
        count1 = length . filter (== "1") . words
        pass = (>= 2) . count1
        results = length $ filter pass ts
    in show results

solve = length . filter (>=2) . map sum
main = interact $ show . solve . map (map read) . map words . tail . lines

import Control.Monad (forM_)

linefun line = (<) 1 . length . filter (== "1") $ words line

main = putStrLn . show . length . filter linefun . tail . lines =<< getContents

solve x = show . sum . map (check . map read . words) $ (drop 1 $ lines x)
          where check x = if sum x > 1 then 1 else 0

main = interact solve

solve :: Int -> Int -> IO ()
solve 0 ans = putStrLn $ show ans
solve n ans = do
  a <- (map read . words) `fmap` getLine
  if (sum a) > 1
    then solve (n - 1) (ans + 1)
    else solve (n - 1) ans

main = do
  n <- read `fmap` getLine;
  solve n 0

main = do
  d <- getContents
  let (n:ls) = lines d
  let xs = map (map read . words) ls
  print $ length $ filter (\t -> sum t >= 2) xs

f x=show$length[ y | y<-[sum$map read (words n) | n<-(tail$lines x)],y>=2]
main=interact$f

main =
  print .
  length .
  filter (>1) .
  map (sum . map read . words) .
  tail .
  lines =<< getContents

-- Codeforces 231A

import Control.Monad

main :: IO ()
main = do
    n <- fmap read getLine
    replicateM n getLine >>= putStrLn . show . solve . map words where
        solve = length . filter (>= 2) . map (sum . map read)

isGood s
    | (sum l) > 1 = 1
    | otherwise = 0
    where l = map (read :: String -> Int).words $ s

main = interact $ show.sum.map isGood.tail.lines

answer :: [[Int]] -> Int
answer = length . filter (>=2) . map sum

main = do interact $ show . answer . map (map read) . map words . tail . lines

main = interact $ show . length . filter ((> 1) . length) . map (filter (== '1')) . tail . lines

main = do
  _ <- getLine
  inputStr <- getContents
  let s = (map (sum . map read . words) . lines) inputStr :: [Int]
  print $ (length . filter (>=2)) s

module Main where

import Data.Maybe (fromJust)
import Control.Monad (foldM, sequence)
import qualified Data.ByteString.Char8 as BS

readNumber :: IO Int
readNumber =
  (fst
   . fromJust
   . BS.readInt) `fmap` BS.getLine

readNumbers :: IO [Int]
readNumbers =
 (fromJust
  . fmap (map fst)
  . sequence
  . map BS.readInt
  . BS.words) `fmap` BS.getLine

main :: IO ()
main = do
  nCases <- readNumber
  result <- foldM (\acc _ -> do
                    howManyKnow <- sum `fmap` readNumbers
                    return (if (howManyKnow >= 2)
                            then succ acc
                            else acc))
                  0
                  [1..nCases]
  print result

import           Control.Monad (replicateM)

main = do
   n <- readLn
   ls <- replicateM n getLine
   print $ length $ filter (\s -> length (filter (== '1') s) >= 2) ls

import Control.Monad

main :: IO ()
main = do
    n:_ <- getList
    matrix <- getLists n
    print $ solve matrix

getList :: (Read a) => IO [a]
getList = fmap (fmap read . words) getLine

getLists :: (Read a) => Int -> IO [[a]]
getLists nRows = replicateM nRows getList

solve :: [[Int]] -> Int
solve matrix = length [row | row <- matrix, sum row >= 2]

solve = length . filter (>=2) . map sum
main = interact $ show . solve . map (map read) . map words . tail . lines

module Main where

(|>) = flip (.)

main = interact $
    lines
    |> drop 1
    |> map (words |> map read)
    |> map sum
    |> filter (>= 2)
    |> length
    |> show

module Main where

infixl 0 |>
(|>) :: a -> (a -> b) -> b
x |> f = f x

getInt :: IO Int
getInt = readLn

process :: (Eq t, Num t) => t -> IO [Int]
process range = process' range []
 where
  process' 0     sums = return sums
  process' range sums = do
    line <- getLine
    let currentSum = line |> words |> map (read :: String -> Int) |> sum
    process' (range - 1) (currentSum : sums)

main :: IO ()
main = do
  range         <- getInt
  processedSums <- process range
  processedSums |> filter (>= 2) |> length |> print

import Control.Applicative

main = interact $ show . length . filter (>1) . map (length . filter (=='1')) . tail . lines

f x=show$length[ y | y<-[sum$map read (words n) | n<-(tail$lines x)],y>=2]
main=interact$f

main :: IO ()
main = do
       arg <- getLine
       let num = read arg
       let spisok = sequence $ replicate num getLine
       sp <- spisok
       let spt = map read $ concat $ map words sp
       print $ solve spt

printSolver :: Int -> IO ()
printSolver 1 = solver
printSolver n = do solver
                   printSolver (n-1)

solver :: IO ()
solver = do
         line <- getLine
         let str = map read $ words line
         print $ solve str

solve :: [Int] -> Int
solve [] = 0
solve (x:y:z:xs) = if x+y+z >= 2 then 1 + solve xs else 0 + solve xs

f xs | (sum xs) > 1 = 1 | 1>0 = 0
main = interact $ show.sum.map f.map (map read.words).tail.lines

main =
  print .
  length .
  filter (>1) .
  map (sum . map read . words) .
  tail .
  lines =<< getContents

import Control.Monad
solve :: [[Int]] -> Int
solve [] = 0
solve (x : xs) = (if sum x > 1 then 1 else 0) + solve xs
main = do
    n <- readLn
    l <- replicateM n getLine
    print . solve $ map (map read . words) l

import Control.Applicative
main= do
	getLine
	s<- length .filter (\z-> elem z ["1 1 1","1 1 0", "1 0 1", "0 1 1"]). lines <$> getContents
	print s

solve = length.filter (>1) . map sum

main = do
	v <- getContents
	print . solve . map (map read) . map words . tail . lines $ v

main = interact $ show . length . filter (>1) . map (sum . (map read . words)) . lines

main = do
    getLine
    cs <- fmap (map (map read . words) . lines) getContents
    print $ map (\l -> sum l >= 2) cs

solve = length.filter (>1) . map sum

main = do
	v <- getContents
	print . solve . map (map read) . map words . lines $ tail v

solve dtms = length $ filter (>=2) $ map sum dtms
main = interact $ show . solve . map (map read . words) . lines

sumInts :: [String] -> Integer
sumInts = sum . map read

consensus :: String -> String
consensus views
  | tot > 1 = "YES"
  | otherwise = "NO"
  where tot = sumInts . words $ views

main = do
  n <- getLine
  interact (unlines . map consensus . lines)

main = interact $ show . length . filter willImplement . tail . lines

willImplement :: String -> Bool
willImplement s = case s of
    "0 1 1" -> True
    "1 1 0" -> True
    "1 1 1" -> True
    otherwise -> False

{-# LANGUAGE OverloadedStrings #-}

import Control.Monad.State
import Control.Monad.Writer.Strict (liftM, replicateM_)
import qualified Data.ByteString.Char8 as C

main = do
  n <- read `fmap` getLine :: IO Int
  r <-
    replicateM n $ do
      q <- C.getLine
      let qs = C.split ' ' q
      if (foldl score 0 qs) >= 2
        then return 1
        else return 0
  putStrLn . show . sum $ r

score :: Int -> C.ByteString -> Int
score s "1" = s + 1
score s _ = s


Nick's company employed n people. Now Nick needs to build a tree hierarchy of «supervisor-surbodinate» relations in the company (this is to say that each employee, except one, has exactly one supervisor). There are m applications written in the following form: «employee ai is ready to become a supervisor of employee bi at extra cost ci». The qualification qj of each employee is known, and for each application the following is true: qai > qbi. Would you help Nick calculate the minimum cost of such a hierarchy, or find out that it is impossible to build it.

The first input line contains integer n (1 ≤ n ≤ 1000) — amount of employees in the company. The following line contains n space-separated numbers qj (0 ≤ qj ≤ 106)— the employees' qualifications. The following line contains number m (0 ≤ m ≤ 10000) — amount of received applications. The following m lines contain the applications themselves, each of them in the form of three space-separated numbers: ai, bi and ci (1 ≤ ai, bi ≤ n, 0 ≤ ci ≤ 106). Different applications can be similar, i.e. they can come from one and the same employee who offered to become a supervisor of the same person but at a different cost. For each application qai > qbi.

Output the only line — the minimum cost of building such a hierarchy, or -1 if it is impossible to build it.

NoteIn the first sample one of the possible ways for building a hierarchy is to take applications with indexes 1, 2 and 4, which give 11 as the minimum total cost. In the second sample it is impossible to build the required hierarchy, so the answer is -1.

import Control.Monad
import Data.Array
import qualified Data.IntMap as M
import Data.List

solve :: Int -> [Int] -> Int -> [(Int, Int, Int)] -> Int
solve n qs m apps =
    foldr rec 0 $ tail $ reverse ms
    where
      rec i res
          | res == -1 = -1
          | otherwise =
              let es = map snd $ filter (\(j, _) -> is ! i < is ! j) $
                       M.findWithDefault [] i edges
              in  if null es then -1 else res + minimum es
      ms = map snd $ sort $ zip qs [1..]
      is = listArray (1, n) $ map snd $ sort $ zip ms [1..]
      edges = M.fromListWith (++) $ map (\(a, b, c) -> (b, [(a, c)])) apps

main = do
  n <- readLn
  qs <- fmap (map read . words) getLine
  m <- readLn
  apps <- replicateM m $ do
            [a, b, c] <- fmap (map read . words) getLine
            return (a, b, c)
  print $ solve n qs m apps

import List

un = map (read :: String -> Int) . words

getLines 0 = return []
getLines n = do
    s <- getLine
    ss <- getLines (n-1)
    return (s:ss)

num max_q (a:s) n | max_q == a = n
                  | True       = num max_q s (n+1)

main = do
    s <- getLine
    s2<- getLine
    s3<- getLine
    let n:_ = un s
        qs = un s2
        m:_ = un s3
        max_q = maximum $ qs
        max_n = num max_q qs 0
    zajav <- getLines m
    let m_zajavlenij = map un zajav
        apps = map (\(a:b:c:s) -> (b,c)) m_zajavlenij
        appsByNum = [ [ (b,c) | (b,c) <- apps, b == emp] | emp <- [1..n]]
        bestApps = map f appsByNum
            where f [] = 0 :: Int
                  f ((b,c):as) = getBest as c :: Int
                  getBest [] c = c :: Int
                  getBest ((_,t):as) c = getBest as (min c t) :: Int
        best_sum = sum bestApps
        notEmp = filter null appsByNum
        notEmpN = length notEmp

    if notEmpN > 1 then
        putStrLn "-1"
        else
            putStrLn $ show best_sum

    --putStrLn $ show apps
    --putStrLn $ show appsByNum
    --putStrLn $ show bestApps
    --putStrLn $ show bestApps
    --putStrLn $ show notEmpN

import Control.Applicative
import Control.Monad
import Data.Function
import Data.Array

solve :: Array Int Int -> Int
solve arr = if z > 1 then -1 else s
  where
    func (a, b) c
        | c == maxBound = (a, b+1)
        | otherwise     = (a+c, b)
    (s, z) = foldl func (0, 0) $ map snd $ assocs arr

main = do
    n <- read <$> getLine :: IO Int
    q <- map read . words <$> getLine :: IO [Int]
    let parseLine [a,b,c] = (read b, read c)
    lists <- read <$> getLine >>= flip replicateM (parseLine . words<$> getLine)
    let arr = accumArray min maxBound (1,n) lists
    print $ solve arr

import List

un = map (read :: String -> Int) . words

getLines 0 = return []
getLines n = do
    s <- getLine
    ss <- getLines (n-1)
    return (s:ss)

uniq [] = []
uniq [a] = [a]
uniq (a:b:s) | a == b = uniq (b:s)
             | True   = a:(uniq (b:s))

uniqBy [] = []
uniqBy [(a,b)] = [b]
uniqBy ((a,b):(c,d):s) | a == c = (min b d):(uniqBy s)
             | True   = b:d:(uniqBy s)

main = do
    s <- getLine
    s2<- getLine
    s3<- getLine
    let n:_ = un s
        qs = un s2
        m:_ = un s3
    zajav <- getLines m
    let m_zajavlenij = map un zajav :: [[Int]]
        list_of_emploers = uniq $ sort $ map (\(a:b:c:s) -> b) m_zajavlenij
    if length list_of_emploers < (n-1) then
            putStrLn "-1"
        else do
        --putStrLn $ show list_of_emploers
        let emp_costs = sort $ map (\(a:b:c:s) -> (b,c)) m_zajavlenij :: [(Int, Int)]
            emp_best = uniqBy  emp_costs
            summa = sum emp_best
        --putStrLn $ show emp_costs
        --putStrLn $ show emp_best
        putStrLn $ show summa


Petya and Vasya are playing a game. Petya's got n non-transparent glasses, standing in a row. The glasses' positions are indexed with integers from 1 to n from left to right. Note that the positions are indexed but the glasses are not.First Petya puts a marble under the glass in position s. Then he performs some (possibly zero) shuffling operations. One shuffling operation means moving the glass from the first position to position p1, the glass from the second position to position p2 and so on. That is, a glass goes from position i to position pi. Consider all glasses are moving simultaneously during one shuffling operation. When the glasses are shuffled, the marble doesn't travel from one glass to another: it moves together with the glass it was initially been put in.After all shuffling operations Petya shows Vasya that the ball has moved to position t. Vasya's task is to say what minimum number of shuffling operations Petya has performed or determine that Petya has made a mistake and the marble could not have got from position s to position t.

The first line contains three integers: n, s, t (1 ≤ n ≤ 105; 1 ≤ s, t ≤ n) — the number of glasses, the ball's initial and final position. The second line contains n space-separated integers: p1, p2, ..., pn (1 ≤ pi ≤ n) — the shuffling operation parameters. It is guaranteed that all pi's are distinct. Note that s can equal t.

If the marble can move from position s to position t, then print on a single line a non-negative integer — the minimum number of shuffling operations, needed to get the marble to position t. If it is impossible, print number -1.

import Control.Monad (liftM)
import Data.Array ((!), listArray)
import Data.Char (ord)
import Data.List (intercalate)

solve :: [Int] -> (Int, Int) -> Int
solve ps (a, b)  =  solve' 0 a
  where
    ps'  =  listArray (1, length ps) ps
    solve' m c
      | c == b  =  m
      | c == a && m > 0  =  -1
      | otherwise  =  solve' (m+1) (ps' ! c)

main :: IO ()
main  =  do
    [n, a, b]  <-  reads
    ps  <-  reads
    print $ solve ps (a, b)

  where

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

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

import Control.Applicative
import qualified Data.ByteString.Char8 as B
import Data.Array.Base

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

main :: IO ()
main = do
  [n,s,t] <- map read.words <$> getLine
  xs <- map readInt.B.words <$> B.getLine
  print $ solve n s t xs

solve n s t xs = go 0 . take n $ iterate (unsafeAt arr) s
   where
     !arr = listArray (0,n) $ 0:xs :: UArray Int Int
     go cnt (y:ys)
       | cnt > n = -1
       | y == t = cnt
       | otherwise = go (cnt+1) ys
     go _ _ = -1

import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe (fromJust)
import Prelude hiding ((.))
(.) a b = b a

main = do
    s1 <- getLine
    s2 <- getLine
    let [n, s, t] = s1 . words . map (read :: String -> Int)
        ps = s2 . words . map (read :: String -> Int)
        ms = Map.fromList (zip [1 .. n] ps)
        visit l c v
            | c == t = l
            | c `Set.member` v = -1
            | otherwise = visit (l + 1) (fromJust $ Map.lookup c ms) (Set.insert c v)
    print (visit 0 s Set.empty)

import qualified Data.IntMap as Map
import qualified Data.IntSet as Set
import Data.Maybe (fromJust)
import Prelude hiding ((.))
(.) a b = b a

main = do
    s1 <- getLine
    s2 <- getLine
    let [n, s, t] = s1 . words . map (read :: String -> Int)
        ps = s2 . words . map (read :: String -> Int)
        ms = Map.fromList (zip [1 .. n] ps)
        visit l c v
            | c == t = l
            | c `Set.member` v = -1
            | otherwise = visit (l + 1) (fromJust $ Map.lookup c ms) (Set.insert c v)
    print (visit 0 s Set.empty)


Polygon is not only the best platform for developing problems but also a square matrix with side $$$n$$$, initially filled with the character 0.On the polygon, military training was held. The soldiers placed a cannon above each cell in the first row and a cannon to the left of each cell in the first column. Thus, exactly $$$2n$$$ cannons were placed.    Initial polygon for $$$n=4$$$. Cannons shoot character 1. At any moment of time, no more than one cannon is shooting. When a 1 flies out of a cannon, it flies forward (in the direction of the shot) until it collides with a polygon border or another 1. After that, it takes the cell in which it was before the collision and remains there. Take a look at the examples for better understanding.More formally:   if a cannon stands in the row $$$i$$$, to the left of the first column, and shoots with a 1, then the 1 starts its flight from the cell ($$$i, 1$$$) and ends in some cell ($$$i, j$$$);  if a cannon stands in the column $$$j$$$, above the first row, and shoots with a 1, then the 1 starts its flight from the cell ($$$1, j$$$) and ends in some cell ($$$i, j$$$). For example, consider the following sequence of shots:   1. Shoot the cannon in the row $$$2$$$.                         2. Shoot the cannon in the row $$$2$$$.                         3. Shoot the cannon in column $$$3$$$. You have a report from the military training on your desk. This report is a square matrix with side length $$$n$$$ consisting of 0 and 1. You wonder if the training actually happened. In other words, is there a sequence of shots such that, after the training, you get the given matrix?Each cannon can make an arbitrary number of shots. Before the training, each cell of the polygon contains 0.

The first line contains an integer $$$t$$$ ($$$1 \le t \le 1000$$$) — the number of test cases. Then $$$t$$$ test cases follow. Each test case starts with a line containing an integer $$$n$$$ ($$$1 \le n \le 50$$$) — the size of the polygon. This is followed by $$$n$$$ lines of length $$$n$$$, consisting of 0 and 1 — the polygon matrix after the training. The total area of the matrices in all test cases in one test does not exceed $$$10^5$$$.

For each test case print:   YES if there is a sequence of shots leading to a given matrix;  NO if such a sequence does not exist.  The letters in the words YES and NO can be printed in any case.

NoteThe first test case was explained in the statement.The answer to the second test case is NO, since a 1 in a cell ($$$1, 1$$$) flying out of any cannon would continue its flight further.

import           Control.Monad
import           Data.Array
import           Data.Maybe
import           Control.Arrow

valid (v, w) = v /= '1' || w == '1'

main :: IO ()
main = do
    t <- read <$> getLine
    replicateM_ t $ do
        n   <- read <$> getLine
        mat <-
            array ((1, 1), (n, n))
            .   zip [ (i, j) | i <- [1 .. n], j <- [1 .. n] ]
            .   concat
            <$> replicateM n getLine
        putStrLn
            $ if and
                      [ (\(i, j) ->
                            ((j + 1) > n || valid
                                    (mat ! (i, j), mat ! (i, j + 1))
                                )
                                || ((i + 1) > n || valid
                                       (mat ! (i, j), mat ! (i + 1, j))
                                   )
                        )
                            (i, j)
                      | i <- [1 .. n]
                      , j <- [1 .. n]
                      ]
                  then "YES"
                  else "NO"

{-- This code was written by
Russell Emerine - linguist,
mathematician, coder,
musician, and metalhead. -}
import Control.Monad
import Data.Bool
import Data.List

main = getLine >>= flip replicateM_ test . read

test = do
    n <- read <$> getLine
    polygon <- replicateM n (map (== '1') <$> getLine)
    let down = tail polygon
        right = tail <$> polygon
        valid = zipWith (zipWith (||)) down right
    putStrLn $ bool "NO" "YES" $ all and $ zipWith (zipWith (||)) ((not <$>) <$> polygon) valid

import Control.Monad (replicateM, replicateM_)
import Data.Array
import Data.Char

readInt :: IO Int
readInt = read <$> getLine

readLine :: IO [Int]
readLine = map digitToInt <$> getLine

getDimensions :: Array (Int, Int) Int -> (Int, Int)
getDimensions = (snd . bounds)

readTable :: IO [[Int]]
readTable =
    read <$> getLine >>= \n ->
    replicateM n readLine

addIndices :: [[Int]] -> [((Int, Int), Int)]
addIndices xss = [((i, j), x) | (i, xs) <- zip [0..] xss,
                                (j, x)  <- zip [0..] xs]

matrixFromList :: [[Int]] -> Array (Int, Int) Int
matrixFromList xss =
    array ((0, 0), (n, m)) (addIndices xss)
    where
        (n, m) = (length xss - 1, (length . head) xss - 1)

isCellValid :: (Int, Int) -> Array (Int, Int) Int -> Bool
isCellValid (i, j) matrix =
    matrix ! (i, j) == 0 ||
    i == n  || j == m ||
    matrix ! (i, j + 1) == 1 ||
    matrix ! (i + 1, j) == 1
    where
        (n, m) = getDimensions matrix

checkMatrix :: Array (Int, Int) Int -> String
checkMatrix matrix = if valid then "YES" else "NO" where
    valid = all (\ idx -> isCellValid idx matrix) (indices matrix)

main =
    readInt >>= \t ->
    replicateM_ t (
        readTable >>= \table ->
        putStrLn $ (checkMatrix . matrixFromList) table
    )

import Control.Monad (replicateM, replicateM_)
import Data.Char

readInt :: IO Int
readInt = read <$> getLine

readLine :: IO [Int]
readLine = map digitToInt <$> getLine

readTable :: IO [[Int]]
readTable =
    read <$> getLine >>= \n ->
    replicateM n readLine

checkMatrix :: [[Int]] -> Bool
checkMatrix m = not $ any (any invalid) (zipWith3 zip3 m ts t) where
    ts = map tail m
    t = tail m
    invalid (x, right, down) = x == 1 && right == 0 && down == 0

main =
    readInt >>= \t ->
    replicateM_ t (
        readTable >>= \m ->
        putStrLn (
            if checkMatrix m then "YES"
            else "NO"
        )
    )

import Control.Monad ( replicateM_ )

readInput = do
    n <- read <$> getLine
    sequenceA $ replicate n (map (=='1') <$> getLine)

buyingShovels :: [[Bool]] -> String
buyingShovels m =
    let a = map tail m
        b = tail m
        zipped = zipWith3 zip3 m a b
    in
        if any (any invalid) zipped
            then "NO"
            else "YES"
    where invalid (t, u, v) = t && not u && not v

main = do
    t <- read <$> getLine
    replicateM_ t (buyingShovels <$> readInput >>= putStrLn)

--- frederick99, 6/2020
--- https://codeforces.com/contest/1360/problem/E

import Control.Monad ( replicateM_ )

polygon :: [[Bool]] -> String
polygon grid =
    let right = map tail grid
        bottom = tail grid
        invalid = zipWith3_2d isValid grid right bottom
    in
        if any or invalid
            then "NO"
            else "YES"
    where
        zipWith3_2d = zipWith3 . zipWith3
        isValid t u v = t && not u && not v

readInput :: IO [[Bool]]
readInput = do
    n <- read <$> getLine
    sequence $ replicate n (map (=='1') <$> getLine)

main :: IO ()
main = do
    t <- read <$> getLine
    replicateM_ t (polygon <$> readInput >>= putStrLn)

import Data.List (transpose)
import Data.Traversable (for, for)

solve :: [[Char]] -> Bool
solve arr = and $ map and ok  where
  supr :: [[Char]] -> [[Bool]]
  supr = map $ \li -> zipWith (<=) li (tail li)
  ok = zipWith (zipWith (||)) (supr arr) (transpose . supr $ transpose arr)

main :: IO ()
main = do
  t <- read <$> getLine :: IO Int
  _ <- for [1..t] $ \_ -> do
    n <- read <$> getLine :: IO Int
    arr <- for [1..n] $ const getLine
    putStrLn $ if  solve arr  then  "YES"  else  "NO"
  return ()


Andrew, Fedor and Alex are inventive guys. Now they invent the game with strings for two players.Given a group of n non-empty strings. During the game two players build the word together, initially the word is empty. The players move in turns. On his step player must add a single letter in the end of the word, the resulting word must be prefix of at least one string from the group. A player loses if he cannot move.Andrew and Alex decided to play this game k times. The player who is the loser of the i-th game makes the first move in the (i + 1)-th game. Guys decided that the winner of all games is the player who wins the last (k-th) game. Andrew and Alex already started the game. Fedor wants to know who wins the game if both players will play optimally. Help him.

The first line contains two integers, n and k (1 ≤ n ≤ 105; 1 ≤ k ≤ 109). Each of the next n lines contains a single non-empty string from the given group. The total length of all strings from the group doesn't exceed 105. Each string of the group consists only of lowercase English letters.

If the player who moves first wins, print "First", otherwise print "Second" (without the quotes).

{-# LANGUAGE MultiParamTypeClasses,FlexibleContexts,FlexibleInstances,TypeSynonymInstances,BangPatterns,RankNTypes,TupleSections #-}
import Control.Applicative
import Control.Arrow

import Data.Function
import Data.List
import Data.Maybe
import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as B

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

main = do
    (_,k) <- readIntPair
    l <- lines <$> getContents
    let t = mkTree l
        a = win t
        b = lose t
        d = case (a,b) of
            (True,True) -> True
            (False,True) -> False
            (True,False) -> odd k
            (False,False) -> False
    putStrLn $ if d then "First" else "Second"

newtype Tree = Node [Tree] deriving(Show,Eq)

mkTree :: [String] -> Tree
mkTree l = Node ls where
    ls = map (mkTree . map tail) $ groupBy ((==) `on` head) $ sortBy (compare `on` head) $ filter (not . null) l

win (Node []) = False
win (Node l)  = or $ map (not.win) l
lose (Node []) = True
lose (Node l) = or $ map (not.lose) l

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

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

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

main = do
    (n,k) <- readIntPair
    l <- lines <$> getContents
    let t = mkTree (sort l)
        a = win t
        b = lose t
        d = case (a,b) of
            (True,True) -> True
            (False,True) -> False
            (True,False) -> odd k
            (False,False) -> False
    putStrLn $ if d then "First" else "Second"

newtype Tree = Node [(Char,Tree)] deriving(Show,Eq)

mkTree :: [String] -> Tree
mkTree l = Node ls where
    ls = map ((head . head) &&& (mkTree . map tail)) $ groupBy (\x y -> head x == head y) $ filter (not . null) l

win (Node []) = False
win (Node l)  = not $ or $ map (win . snd) l
lose (Node []) = True
lose (Node l) = not $ or $ map (lose . snd) l

{-# LANGUAGE MultiParamTypeClasses,FlexibleContexts,FlexibleInstances,TypeSynonymInstances,BangPatterns,RankNTypes,TupleSections #-}
import Control.Applicative
import Control.Arrow

import Data.Function
import Data.List
import Data.Maybe
import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as B

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

main = do
    (_,k) <- readIntPair
    l <- lines <$> getContents
    let t = mkTree l
        a = win t
        b = lose t
        d = case (a,b) of
            (True,True) -> True
            (False,True) -> False
            (True,False) -> odd k
            (False,False) -> False
    putStrLn $ if d then "First" else "Second"

newtype Tree = Node [Tree] deriving(Show,Eq)

mkTree :: [String] -> Tree
mkTree l = Node ls where
    ls = map (mkTree . map tail) $ groupBy ((==) `on` head) $ sortBy (compare `on` head) $ filter (not . null) l

win (Node []) = False
win (Node l)  = not $ or $ map win l
lose (Node []) = True
lose (Node l) = not $ or $ map lose l


You are the organizer of the famous "Zurich Music Festival". There will be $$$n$$$ singers who will perform at the festival, identified by the integers $$$1$$$, $$$2$$$, $$$\dots$$$, $$$n$$$. You must choose in which order they are going to perform on stage. You have $$$m$$$ friends and each of them has a set of favourite singers. More precisely, for each $$$1\le i\le m$$$, the $$$i$$$-th friend likes singers $$$s_{i,1}, \, s_{i, 2}, \, \dots, \,s_{i, q_i}$$$.A friend of yours is happy if the singers he likes perform consecutively (in an arbitrary order). An ordering of the singers is valid if it makes all your friends happy.Compute the number of valid orderings modulo $$$998\,244\,353$$$.

The first line contains two integers $$$n$$$ and $$$m$$$ ($$$1\le n,\,m\le 100$$$) — the number of singers and the number of friends correspondingly. The $$$i$$$-th of the next $$$m$$$ lines contains the integer $$$q_i$$$ ($$$1\le q_i\le n$$$) — the number of favorite singers of the $$$i$$$-th friend – followed by the $$$q_i$$$ integers $$$s_{i,1}, \, s_{i, 2}, \, \dots, \,s_{i, q_i}$$$ ($$$1\le s_{i,1}<s_{i,2}<\cdots<s_{i,q_i}\le n$$$) — the indexes of his favorite singers.

Print the number of valid orderings of the singers modulo $$$998\,244\,353$$$.

NoteExplanation of the first sample: There are $$$3$$$ singers and only $$$1$$$ friend. The friend likes the two singers $$$1$$$ and $$$3$$$. Thus, the $$$4$$$ valid orderings are:   1 3 2  2 1 3  2 3 1  3 1 2 Explanation of the second sample: There are $$$5$$$ singers and $$$5$$$ friends. One can show that no ordering is valid.Explanation of the third sample: There are $$$100$$$ singers and only $$$1$$$ friend. The friend likes only singer $$$50$$$, hence all the $$$100!$$$ possible orderings are valid.Explanation of the fourth sample: There are $$$5$$$ singers and only $$$1$$$ friend. The friend likes all the singers, hence all the $$$5!=120$$$ possible orderings are valid.

import Control.Applicative
import Control.Monad
import Control.Monad.State
import Data.Either
import Data.List
import Data.Maybe
import qualified Data.IntSet as IS

m :: Int
m = 998244353

mulmod :: Int -> Int -> Int
mulmod a b = a * b `mod` m

count :: PQNode -> Int
count (PQLeaf _) = 1
count (PNode cs) = foldl1' mulmod $ zipWith mulmod [1..] $ map count cs
count (QNode cs) = mulmod 2 $ foldl1' mulmod $ map count cs

solve :: IO ()
solve = do
    [n, m] <- readMany
    xss <- map tail <$> replicateM m readMany
    print $ maybe 0 count $ reduceAllPQ xss $ buildPQ [1..n]

readMany :: Read a => IO [a]
readMany = map read . words <$> getLine

main :: IO ()
main = solve

--------------------------------------------------------------------------------

data PQNode = PQLeaf !Int
            | PNode  [PQNode]
            | QNode  [PQNode]
            deriving Show

type Parts = ([PQNode], [PQNode]) -- empty and full, end first
data RNode = Empty PQNode
           | Full  PQNode
           | Part  Parts
           deriving Show

mkPNode, mkQNode :: [PQNode] -> PQNode
mkPNode []     = error "empty PNode"
mkPNode [n]    = n
mkPNode ns     = PNode ns
mkQNode []     = error "empty QNode"
mkQNode [n]    = n
mkQNode [n, m] = PNode [n, m]
mkQNode ns     = QNode ns

mkPartial :: [PQNode] -> [PQNode] -> RNode
mkPartial [] _  = error "empty RNode es"
mkPartial _  [] = error "empty RNode fs"
mkPartial es fs = Part (es, fs)

emptyMany, fullMany :: State [RNode] [PQNode]
emptyMany = state $ go [] where
    go ys (Empty n : xs) = go (n:ys) xs
    go ys xs             = (reverse ys, xs)
fullMany = state $ go [] where
    go ys (Full n : xs) = go (n:ys) xs
    go ys xs            = (reverse ys, xs)

partialMaybe :: State [RNode] (Maybe Parts)
partialMaybe = state go where
    go (Part p : xs) = (Just p,  xs)
    go xs            = (Nothing, xs)

splitForP :: [RNode] -> ([PQNode], [Parts], [PQNode])
splitForP us = go us [] [] [] where
    go []     es ps fs = (es, ps, fs)
    go (x:xs) es ps fs = case x of
        Empty n -> go xs (n:es) ps     fs
        Part p  -> go xs es     (p:ps) fs
        Full n  -> go xs es     ps     (n:fs)

splitForQ :: [RNode] -> Maybe ([PQNode], Maybe Parts, [PQNode])
splitForQ xs = go xs <|> go (reverse xs) where
    go = evalState $ go' <$> emptyMany <*> partialMaybe <*> fullMany <*> gets null
    go' es ps fs end = (es, ps, fs) <$ guard end

splitForQRoot :: [RNode] -> Maybe ([PQNode], Maybe Parts, [PQNode], Maybe Parts, [PQNode])
splitForQRoot = evalState $
    go <$> emptyMany <*> partialMaybe <*> fullMany <*> partialMaybe <*> emptyMany <*> gets null
  where
    go es1 ps1 fs ps2 es2 end = (es1, ps1, fs, ps2, es2) <$ guard end

buildPQ :: [Int] -> PQNode
buildPQ = mkPNode . map PQLeaf

reducePQ :: [Int] -> PQNode -> Maybe PQNode
reducePQ []  = Just
reducePQ xs0 = fromRight (error "outside initial set") . visit where
    xs = IS.fromList xs0
    xsz = IS.size xs

    visit :: PQNode -> Either Int (Maybe PQNode)
    visit n@(PNode cs) = visitPQ n PNode cs
    visit n@(QNode cs) = visitPQ n QNode cs
    visit n@(PQLeaf x)
        | x `IS.notMember` xs = Left 0
        | xsz > 1             = Left 1
        | otherwise           = Right $ reduceRoot n
    visitPQ n f cs
        | cnt == xsz  = Right $ reduceRoot n
        | null rts    = Left cnt
        | ~[r] <- rts = Right $ f . getcs' <$> r
      where
        ys = map visit cs
        cnt = sum $ lefts ys
        rts = rights ys
        getcs' c' = zipWith (\c -> either (const c) (const c')) cs ys

    reduceRoot :: PQNode -> Maybe PQNode
    reduceRoot n@(PNode cs) = go . splitForP =<< mapM reduceInternal cs where
        go (es, ps, fs) = case ps of
            []       -> Just noPartial
            [p1]     -> Just $ withPartial p1 ([], [])
            [p1, p2] -> Just $ withPartial p1 p2
            _        -> Nothing
          where
            noPartial
                | null es || null fs = n
                | otherwise          = mkPNode $ mkPNode fs : es
            withPartial (pe1, pf1) (pe2, pf2) = mkPNode $ qn : es where
                qn = mkQNode $
                    pe1 ++ reverse pf1 ++ [mkPNode fs | not (null fs)] ++ pf2 ++ reverse pe2

    reduceRoot n@(QNode cs) = fmap go . splitForQRoot =<< mapM reduceInternal cs where
        go (es1, ps1, fs, ps2, es2) = case (ps1, ps2) of
            (Nothing, Nothing) -> n
            _                  -> withPartial (fromMaybe ([], []) ps1) (fromMaybe ([], []) ps2)
          where
            withPartial (pe1, pf1) (pe2, pf2) =
                mkQNode $ es1 ++ pe1 ++ reverse pf1 ++ fs ++ pf2 ++ reverse pe2 ++ es2

    reduceRoot n@(PQLeaf _) = Just n

    reduceInternal :: PQNode -> Maybe RNode
    reduceInternal n@(PNode cs) = go . splitForP =<< mapM reduceInternal cs where
        go (es, ps, fs) = case ps of
            []   -> Just noPartial
            [p1] -> Just $ withPartial p1
            _    -> Nothing
          where
            noPartial
                | null es   = Full n
                | null fs   = Empty n
                | otherwise = mkPartial [mkPNode es] [mkPNode fs]
            withPartial (pe, pf) = mkPartial
                ([mkPNode es | not (null es)] ++ pe) ([mkPNode fs | not (null fs)] ++ pf)

    reduceInternal n@(QNode cs) = fmap go . splitForQ =<< mapM reduceInternal cs where
        go (es, ps, fs) = maybe noPartial withPartial ps where
            noPartial
                | null es   = Full n
                | null fs   = Empty n
                | otherwise = mkPartial es (reverse fs)
            withPartial (pe, pf) = mkPartial (es ++ pe) (reverse fs ++ pf)

    reduceInternal n@(PQLeaf x) = Just $ if x `IS.member` xs then Full n else Empty n

reduceAllPQ :: [[Int]] -> PQNode -> Maybe PQNode
reduceAllPQ xss t = foldM (flip reducePQ) t xss

import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Data.Either
import Data.Int
import Data.List
import Data.Maybe
import qualified Data.IntSet as IS

-- Implementing this gave me a headache
data PQNode = PQLeaf !Int
            | PNode [PQNode]
            | QNode [PQNode]
            deriving Show

data RNode = Em { unRNode :: PQNode }
           | Fu { unRNode :: PQNode }
           | Pa [PQNode] [PQNode] -- empty and full, end first
           deriving Show

mkPNode, mkQNode :: [PQNode] -> PQNode
mkPNode []     = error "empty PNode"
mkPNode [n]    = n
mkPNode ns     = PNode ns
mkQNode []     = error "empty QNode"
mkQNode [n]    = n
mkQNode [n, m] = PNode [n, m]
mkQNode ns     = QNode ns

mkRNode :: [PQNode] -> [PQNode] -> RNode
mkRNode [] _  = error "empty RNode es"
mkRNode _ []  = error "empty RNode fs"
mkRNode es fs = Pa es fs

isFu, isEm, isPa :: RNode -> Bool
isFu (Fu _)   = True
isFu _        = False
isEm (Em _)   = True
isEm _        = False
isPa (Pa _ _) = True
isPa _        = False

splitForP :: [RNode] -> ([PQNode], [RNode], [PQNode])
splitForP us = go us [] [] [] where
    go []     e p f = (e, p, f)
    go (x:xs) e p f = case x of
        Em n   -> go xs (n:e) p     f
        Pa _ _ -> go xs e     (x:p) f
        Fu n   -> go xs e     p     (n:f)

span1 :: (a -> Bool) -> [a] -> ([a], [a])
span1 _ [] = ([], [])
span1 f xs@(x:xs')
    | f x       = ([x], xs')
    | otherwise = ([],  xs)

splitForQ :: [RNode] -> Maybe ([PQNode], [RNode], [PQNode])
splitForQ xs = go xs <|> go (reverse xs) where
    go = evalStateT $ do
        ~[es, ps, fs] <- mapM state [span isEm, span1 isPa, span isFu]
        lift . ((map unRNode es, ps, map unRNode fs) <$) . guard =<< gets null

splitForQRoot :: [RNode] -> Maybe ([PQNode], [RNode], [PQNode], [RNode], [PQNode])
splitForQRoot = evalStateT $ do
    ~[e1, p1, fs, p2, e2] <- mapM state [span isEm, span1 isPa, span isFu, span1 isPa, span isEm]
    lift . ((map unRNode e1, p1, map unRNode fs, p2, map unRNode e2) <$) . guard =<< gets null

buildPQ :: [Int] -> PQNode
buildPQ = mkPNode . map PQLeaf

reducePQ :: [Int] -> PQNode -> Maybe PQNode
reducePQ [] = Just
reducePQ xs0 = fromRight (error "outside initial set") . visit where
    xs = IS.fromList xs0

    visit :: PQNode -> Either Int (Maybe PQNode)
    visit n@(PNode cs) = visitPQ n PNode cs
    visit n@(QNode cs) = visitPQ n QNode cs
    visit n@(PQLeaf x)
        | x `IS.notMember` xs = Left 0
        | IS.size xs > 1      = Left 1
        | otherwise           = Right $ reduceRoot n
    visitPQ n f cs
        | cnt == IS.size xs = Right $ reduceRoot n
        | null rts          = Left cnt
        | ~[r] <- rts       = Right $ f cs' <$ r
      where
        ys = map visit cs
        cnt = sum $ lefts ys
        rts = rights ys
        cs' = zipWith (\c e -> either (const c) fromJust e) cs ys

    reduceRoot :: PQNode -> Maybe PQNode
    reduceRoot = go where
        go n@(PNode cs) = do
            (es, ps, fs) <- splitForP <$> mapM reduceInternal cs
            let noPartial
                    | null es || null fs = n
                    | otherwise          = mkPNode $ mkPNode fs : es
                withPartial pe1 pf1 pe2 pf2 = mkPNode $ qn : es where
                    qn = mkQNode $
                        pe1 ++ reverse pf1 ++ [mkPNode fs | not (null fs)] ++ pf2 ++ reverse pe2
            case ps of
                []                       -> Just noPartial
                [Pa pe1 pf1]             -> Just $ withPartial pe1 pf1 [] []
                [Pa pe1 pf1, Pa pe2 pf2] -> Just $ withPartial pe1 pf1 pe2 pf2
                _                        -> Nothing

        go n@(QNode cs) = do
            (e1, p1, fs, p2, e2) <- splitForQRoot =<< mapM reduceInternal cs
            let withPartial pe1 pf1 pe2 pf2 =
                    mkQNode $ e1 ++ pe1 ++ reverse pf1 ++ fs ++ pf2 ++ reverse pe2 ++ e2
            case (p1, p2) of
                ([],           [])           -> Just n
                ([Pa pe1 pf1], [])           -> Just $ withPartial pe1 pf1 []  []
                ([],           [Pa pe2 pf2]) -> Just $ withPartial []  []  pe2 pf2
                ([Pa pe1 pf1], [Pa pe2 pf2]) -> Just $ withPartial pe1 pf1 pe2 pf2
                _                            -> Nothing

        go n@(PQLeaf _) = Just n

    reduceInternal :: PQNode -> Maybe RNode
    reduceInternal = go where
        go n@(PNode cs) = do
            (es, ps, fs) <- splitForP <$> mapM go cs
            let noPartial
                    | null es   = Fu n
                    | null fs   = Em n
                    | otherwise = mkRNode [mkPNode es] [mkPNode fs]
                withPartial pe pf =
                    mkRNode ([mkPNode es | not (null es)] ++ pe) ([mkPNode fs | not (null fs)] ++ pf)
            case ps of
                []         -> Just noPartial
                [Pa pe pf] -> Just $ withPartial pe pf
                _          -> Nothing

        go n@(QNode cs) = do
            (es, ps, fs) <- splitForQ =<< mapM go cs
            let noPartial
                    | null es = Fu n
                    | null fs = Em n
                    | otherwise = mkRNode es (reverse fs)
                withPartial pe pf = mkRNode (es ++ pe) (reverse fs ++ pf)
            case ps of
                []         -> Just noPartial
                [Pa pe pf] -> Just $ withPartial pe pf
                _          -> Nothing

        go n@(PQLeaf x) = Just $ if x `IS.member` xs then Fu n else Em n

reduceAllPQ :: [[Int]] -> PQNode -> Maybe PQNode
reduceAllPQ xss t = foldM (flip reducePQ) t xss

m :: Int64
m = 998244353

mulmod :: Int64 -> Int64 -> Int64
mulmod a b = a * b `mod` m

count :: PQNode -> Int64
count (PQLeaf _) = 1
count (PNode cs) = foldl1' mulmod $ zipWith mulmod [1..] $ map count cs
count (QNode cs) = mulmod 2 $ foldl1' mulmod $ map count cs

solve :: IO ()
solve = do
    [n, m] <- readMany
    xss <- map tail <$> replicateM m readMany
    print $ maybe 0 count $ reduceAllPQ xss $ buildPQ [1..n]

readMany :: Read a => IO [a]
readMany = map read . words <$> getLine

main :: IO ()
main = solve


Vasya has found a piece of paper with an array written on it. The array consists of n integers a1, a2, ..., an. Vasya noticed that the following condition holds for the array ai ≤ ai + 1 ≤ 2·ai for any positive integer i (i < n).Vasya wants to add either a "+" or a "-" before each number of array. Thus, Vasya will get an expression consisting of n summands. The value of the resulting expression is the sum of all its elements. The task is to add signs "+" and "-" before each number so that the value of expression s meets the limits 0 ≤ s ≤ a1. Print a sequence of signs "+" and "-", satisfying the given limits. It is guaranteed that the solution for the problem exists.

The first line contains integer n (1 ≤ n ≤ 105) — the size of the array. The second line contains space-separated integers a1, a2, ..., an (0 ≤ ai ≤ 109) — the original array.  It is guaranteed that the condition ai ≤ ai + 1 ≤ 2·ai fulfills for any positive integer i (i < n).

In a single line print the sequence of n characters "+" and "-", where the i-th character is the sign that is placed in front of number ai. The value of the resulting expression s must fit into the limits 0 ≤ s ≤ a1. If there are multiple solutions, you are allowed to print any of them.

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

main :: IO ()
main = do
  (h:t) <- fmap (reverse . map (fst . fromJust . C.readInt) . tail . C.words) C.getContents
  let (x, y) = foldl gao (h, "+") t
  putStrLn $ if x >= 0 then y else map (\i -> if i == '+' then '-' else '+') y
  where
    gao (x, s) y
      | x + y <= y  = (x + y, '+': s)
      | otherwise   = (x - y, '-': s)

import qualified Data.ByteString.Char8 as BS
import Data.Maybe (fromJust)

-- main = do (_:as) <- (map (fst . fromJust . BS.readInt) . BS.words) `fmap` BS.getContents
--           putStrLn $ solve'' (reverse as)

main = do (_:as) <- (map read . words) `fmap` getContents
          putStrLn $ solve'' (reverse as)

solve' as     = fst $ foldl (\(ops, s) a ->
                              if a <= s
                              then ('-':ops, s-a)
                              else ('+':(map rev ops), a-s)
                            ) ("+", head as) (tail as)
rev '+' = '-'
rev '-' = '+'

solve'' as = (\(ops, s) ->
               if s <= 0
               then map rev ops
               else ops
             )
             $ foldl (\(ops, s) a ->
                       if s <= 0
                       then ('+':ops, s+a)
                       else ('-':ops, s-a)
                     ) ("+", head as) (tail as)

import qualified Data.ByteString.Char8 as BS
import Data.Maybe (fromJust)

main = do (_:as) <- (map (fst . fromJust . BS.readInt) . BS.words) `fmap` BS.getContents
          putStrLn $ solve'' (reverse as)

-- main = do (_:as) <- (map read . words) `fmap` getContents
--           putStrLn . fst $ solve' (reverse as)

solve' as     = fst $ foldl (\(ops, s) a ->
                              if a <= s
                              then ('-':ops, s-a)
                              else ('+':(map rev ops), a-s)
                            ) ("+", head as) (tail as)
rev '+' = '-'
rev '-' = '+'

solve'' as = (\(ops, s) ->
               if s <= 0
               then map rev ops
               else ops
             )
             $ foldl (\(ops, s) a ->
                       if s <= 0
                       then ('+':ops, s+a)
                       else ('-':ops, s-a)
                     ) ("+", head as) (tail as)

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

main = putStrLn . solve . map (maybe 0 fst . B.readInt) . B.words =<< B.getContents

solve :: [Int] -> String
solve (_ : as) = g False $ snd $ foldr f (0, "") as
  where
  f a (s, x)
    | a > s = (a - s, '+' : x)
    | otherwise = (s - a, '-' : x)
  g False ('+' : x) = '+' : g True  x
  g False ('-' : x) = '-' : g False x
  g True  ('+' : x) = '-' : g False x
  g True  ('-' : x) = '+' : g True  x
  g _ _ = []

next :: (Integer, String) -> Integer -> (Integer, String)
next (s, r) a
  | s < 0  = (s + a, "+" ++ r)
  | s >= 0 = (s - a, "-" ++ r)

inv :: Char -> Char
inv '-' = '+'
inv '+' = '-'

main :: IO ()
main = do
  _ <- getLine
  ais <- fmap (map read . reverse . words) getLine
  let (si, res) = foldl next (0, "") ais
  if si < 0 then
      putStrLn $ map inv res
    else
      putStrLn res

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

main = do
	ct <- C.getContents
	let
		(n:t) = map (fst.fromJust.C.readInt) $ C.words ct
	putStrLn $ adjust $ solve (reverse t)

adjust (s,x)
	| x < 0 = map (\x -> if x == '+' then '-' else '+') s | otherwise = s

solve :: [Int] -> (String,Int)
solve (h:t) = foldl cal ("+",h) t
	where
		cal (s,x) y
			| x + y <= y = ('+':s, x+y)
			| otherwise = ('-':s, x-y)

--solve (x:[]) v = if x < v then ("-",0) else ("+",1)
--solve (x:xs) v = if x < v then
--					let
--						(seq,flag) = solve xs (v-x)
--					in
--						if flag==1 then (seq++"+",1) else (seq++"-",0)
--				else
--					let
--						(seq,flag) = solve xs (x-v)
--					in
--						if flag==1 then (seq++"-",0) else (seq++"+",1)

next :: (Integer, String) -> Integer -> (Integer, String)
next (s, r) a
  | s < 0  = (s + a, r ++ "+")
  | s >= 0 = (s - a, r ++ "-")

inv :: Char -> Char
inv '-' = '+'
inv '+' = '-'

main :: IO ()
main = do
  _ <- getLine
  ais <- fmap (map read . reverse . words) getLine
  let (si, res) = foldl next (0, "") ais
  if si < 0 then
      putStrLn $ map inv res
    else
      putStrLn res


Bachgold problem is very easy to formulate. Given a positive integer n represent it as a sum of maximum possible number of prime numbers. One can prove that such representation exists for any integer greater than 1.Recall that integer k is called prime if it is greater than 1 and has exactly two positive integer divisors — 1 and k.

The only line of the input contains a single integer n (2 ≤ n ≤ 100 000).

The first line of the output contains a single integer k — maximum possible number of primes in representation. The second line should contain k primes with their sum equal to n. You can print them in any order. If there are several optimal solution, print any of them.

import Control.Monad
import Data.List

getInt = read `fmap` getLine :: IO Int

main = do
    n <- getInt
    let ps = fact n
    print $ length ps
    forM_ ps $ \p -> do
        putStr (show p)
        putChar ' '

fact n
    | even n = m
    | otherwise = 3 : tail m
    where m = replicate (n `div` 2) 2

main :: IO ()
main = do
  n_s <- getLine
  let n = read n_s :: Int
  if n < 4
    then do
      putStrLn "1"
      putStrLn (show n)
    else do
      let r = (n `div` 2)
      print r
      mapM_ (\_ -> do
                putStr "2 "
                ) [1..(r-2)]
      putStr "2 "
      if (n `mod` 2) == 1 then putStrLn "3" else putStrLn "2"

sol :: Int -> IO ()
sol n = do
  mapM_ putStr ["2 " | _ <- [1..((n `div` 2) - 1)]]
  if (n `mod` 2 == 0)
    then putStrLn "2"
    else putStrLn "3"

main :: IO ()
main = do
  n <- getLine
  let ni = read n :: Int
  print (ni `div` 2)
  sol ni

import Data.List

sol :: Int -> IO ()
sol n = do
  mapM_ putStr (replicate ((n `div` 2) - 1) "2 ")
  if (n `mod` 2 == 0)
    then putStrLn "2"
    else putStrLn "3"

main :: IO ()
main = do
  n <- getLine
  let ni = read n :: Int
  print (ni `div` 2)
  sol ni

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}

import Control.Applicative
import Control.Monad
import Control.Arrow
import Data.List
import Data.Maybe
import Data.Char
import qualified Data.ByteString.Char8 as B
import Text.Printf

readInt = ( readLn :: IO Int )
readInts = map ( read :: String -> Int ) . words <$> getLine

getList = map ( fst . fromJust . B.readInt ) . B.words <$> B.getLine

which a b f = if f then a else b
mp [ a, b ] = ( a, b )

main = do
	n <- readInt
	let
		res = solve n
	print $ length res
	putStrLn $ unwords $ map show res

solve 2 = [ 2 ]
solve 3 = [ 3 ]
solve n = 2 : solve ( n - 2 )

import Data.List
import Data.Tree
import Data.Int
import Data.Maybe
import Data.Char
import Data.Functor
import Data.Bits
import Data.Monoid
import Control.Monad
import Control.Monad.ST.Safe
import Control.Arrow
import Data.Array
import Data.Array.ST.Safe
import Data.Array.Unboxed as UA
import Data.STRef
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as C
main=   readsolveprint
readsolveprint::IO()
readsolveprint = (solve.concat =<< forM [1.. 1] ( \i -> map (fst.fromJust.C.readInt).C.words<$>C.getLine))
solve [x] = let f=x `mod` 2; d=x `div` 2 in if  f== 0 then print d>>putStr (unwords $ map show $ take d (repeat 2)) else print (d)>>putStr (unwords $ map show $ (++) [3] $ take (d-1) (repeat 2))

main = getLine >>= putStrLn . calc . read

calc :: Int -> String
calc n = unlines ans
  where ans = [show k, unwords $ map show (calc' $ n - 2)]
        k = n `div` 2
        calc' 1 = [3]
        calc' 0 = [2]
        calc' n = 2:(calc' $ n - 2)

import Text.Printf
import Data.List
import Data.Functor
import Control.Applicative
import Prelude
import Control.Monad
import Data.Maybe
import Data.Function
import Data.Array
import qualified Data.ByteString.Char8 as B8
import Data.Foldable (foldr')

readInt :: String -> Int
readInt = Prelude.read

readB8Int :: B8.ByteString -> Int
readB8Int = fst . fromJust . B8.readInt

solve :: Int -> [Int]
solve 2 = [2]
solve 3 = [3]
solve x = 2 : solve (x - 2)

main :: IO ()
main = do
    n <- readInt <$> getLine
    let answer = solve n
    printf "%d\n" $ length answer
    forM_ answer $ printf "%d "
    printf "\n"

import Control.Applicative
import Data.List
import Data.Char

main=do
    a<-read <$> getLine::IO Int
    let b = (div a 2)
    print b
    putStrLn $ intercalate " " $ map show $ (replicate (b-1) 2) ++ [(if mod a 2==1 then 3 else 2)]

import Control.Monad
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as B

readInt = readLn :: IO Int
readInts = map ( fst . fromJust . B.readInt ) . B.words <$> B.getLine

format (a, b) = show a ++ "\n" ++ (unwords $ map show b)

solve :: Int -> (Int, [Int])
solve x
    | even x    = (n, replicate n 2)
    | otherwise = (n, 3 : replicate (n - 1) 2)
        where n = div x 2

main :: IO ()
main = do
    x <- readInt
    putStrLn $ format $ solve x

main = do
  n <- readLn
  let d = n `div` 2
  if even n
    then do
      print d
      putStrLn $ unwords $ replicate d "2"
    else do
      print d
      putStrLn $ unwords $ "3" : replicate (d-1) "2"

import Control.Monad( replicateM_)
main = do
    k_ <- readLn
    let solve k = let (d,m) = k `divMod` 2 in if m==0
		    then do
			print d
			replicateM_ d (putStr "2 ")
		    else do
			print d
			replicateM_ (d-1) (putStr "2 ")
			print 3
    solve k_

module Main where
    solve :: Integer -> [Integer]
    solve x = if x <= 3 then [x] else [2] ++ solve (x - 2)

    main :: IO ()
    main = do
        l <- getLine
        let n = read l :: Integer
            ans = solve n
            res = concat $ map (\x -> show x ++ " ") $ ans
        print $ length ans
        putStrLn res

module Main where

import Control.Applicative
import Data.List

solve :: Int -> [Int]
solve 0 = []
solve n | odd n     = 3 : solve (n - 3)
        | otherwise = 2 : solve (n - 2)

main = do
    n <- read <$> getLine
    let a = solve n
    print $ length a
    putStrLn $ intercalate " " (map show a)

import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe
import Data.Array

main= do
	n<-  read <$> getLine ::IO Int
	let c=  div n 2
	let d= concat $ replicate (c-1) "2 "
	let e = if (mod n 2 ==0 ) then "2 " else "3 "
	print  c
	putStrLn $ e++d

--ghc 7.10

bachgold :: Int -> [Int]
bachgold 2 = [2]
bachgold 3 = [3]
bachgold n = 2:bachgold (n-2)

main = do
    nStr <- getLine
    let n = read nStr :: Int
    let a = bachgold n
    print . length $ a
    putStrLn . unwords . map show $ a

{-# LANGUAGE FlexibleInstances #-}
module Main (printShit, printShitV, readShit, main, yN) where
import Data.ByteString.Builder
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Maybe
-- Meat

solve :: Int -> [[Int]]
solve n = [[length d], d]
    where d = decompose  n

decompose :: Int -> [Int]
decompose 2 = [2]
decompose 3 = [3]
decompose x = 2 : decompose (x - 2)

-- Shit
main :: IO ()
main = do
        [n]  <- readShit
        printShit $ solve n

class Shit a where
    printShit :: a -> IO ()
    printShitV :: a -> IO ()
    readShit :: IO a
    printShitV = printShit

yN :: Bool -> String
yN True = "YES"
yN False = "NO"

instance  Shit Int where
    printShit = print
    readShit = fmap read getLine

instance  Shit [Int] where
    printShit = putStrLn . unwords . fmap show
    printShitV = putStrLn . unlines . fmap show
    readShit = fmap (fmap read . words) getLine

instance  Shit [Integer] where
    printShit = putStrLn . unwords . fmap show
    printShitV = putStrLn . unlines . fmap show
    readShit = fmap (fmap read . words) getLine

instance Shit [[Int]] where
    printShit = printShit . (fmap.fmap)  (toLazyByteString . integerDec .toInteger)
    readShit = fmap (fmap.fmap $ fromInteger.fst.fromJust. BS.readInteger) readShit

instance Shit [[Double]] where
    printShit = printShit . (fmap.fmap) show
    readShit = fmap (fmap.fmap $ read) readShit

instance Shit [[Integer]] where
    printShit  = printShit . (fmap.fmap)  (toLazyByteString . integerDec)
    readShit = fmap (fmap.fmap $ fromInteger.fst.fromJust. BS.readInteger) readShit

instance Shit [String] where
    printShit = putStrLn. unwords
    printShitV = putStrLn . unlines
    readShit = fmap lines getContents

instance Shit [[String]] where
    printShit = putStrLn . unlines . fmap unwords
    readShit = fmap (fmap (fmap words) lines) getContents

instance Shit [BS.ByteString] where
    printShit = BS.putStrLn. BS.unwords
    printShitV = BS.putStrLn . BS.unlines
    readShit = fmap BS.lines BS.getContents

instance Shit [[BS.ByteString]] where
    printShit = BS.putStrLn . BS.unlines . fmap BS.unwords
    readShit = fmap (fmap (fmap BS.words) BS.lines) BS.getContents

solve n | n > 3     = 2 : solve (n-2)
        | otherwise = [n]

printList [x] = print x
printList (x : xs) = do
  putStr $ show x
  putStr " "
  printList xs

main = do
  s <- getContents
  let n = read s
  let l = solve n
  print $ length l
  printList l

import Data.List

sol :: Int -> [Int]
sol n = if n == 3
  then [3]
  else 2:(sol (n-2))

main :: IO ()
main = do
  n <- getLine
  putStrLn (intercalate " " (map show (sol (read n :: Int))))

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}

import Control.Applicative
import Control.Monad
import Control.Arrow
import Data.List
import Data.Maybe
import Data.Char
import qualified Data.ByteString.Char8 as B
import Text.Printf

readInt = ( readLn :: IO Int )
readInts = map ( read :: String -> Int ) . words <$> getLine

getList = map ( fst . fromJust . B.readInt ) . B.words <$> B.getLine

which a b f = if f then a else b
mp [ a, b ] = ( a, b )

main = readInt >>= putStrLn . unwords . map show . solve

solve 2 = [ 2 ]
solve 3 = [ 3 ]
solve n = 2 : solve ( n - 2 )

import Control.Applicative
import Data.List
import Data.Char

main=do
    a<-read <$> getLine::IO Int
    print $ (div a 2) +(mod a 2)

main = do
  n <- readLn
  let d = n `div` 2
  if even n
    then do
      print d
      putStrLn $ unwords $ replicate d "2"
    else do
      print (d+1)
      putStrLn $ unwords $ "3" : replicate d "2"


You are given a matrix with $$$n$$$ rows (numbered from $$$1$$$ to $$$n$$$) and $$$m$$$ columns (numbered from $$$1$$$ to $$$m$$$). A number $$$a_{i, j}$$$ is written in the cell belonging to the $$$i$$$-th row and the $$$j$$$-th column, each number is either $$$0$$$ or $$$1$$$.A chip is initially in the cell $$$(1, 1)$$$, and it will be moved to the cell $$$(n, m)$$$. During each move, it either moves to the next cell in the current row, or in the current column (if the current cell is $$$(x, y)$$$, then after the move it can be either $$$(x + 1, y)$$$ or $$$(x, y + 1)$$$). The chip cannot leave the matrix.Consider each path of the chip from $$$(1, 1)$$$ to $$$(n, m)$$$. A path is called palindromic if the number in the first cell is equal to the number in the last cell, the number in the second cell is equal to the number in the second-to-last cell, and so on.Your goal is to change the values in the minimum number of cells so that every path is palindromic.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 200$$$) — the number of test cases. The first line of each test case contains two integers $$$n$$$ and $$$m$$$ ($$$2 \le n, m \le 30$$$) — the dimensions of the matrix. Then $$$n$$$ lines follow, the $$$i$$$-th line contains $$$m$$$ integers $$$a_{i, 1}$$$, $$$a_{i, 2}$$$, ..., $$$a_{i, m}$$$ ($$$0 \le a_{i, j} \le 1$$$).

For each test case, print one integer — the minimum number of cells you have to change so that every path in the matrix is palindromic.

NoteThe resulting matrices in the first three test cases: $$$\begin{pmatrix} 1 & 1\\ 0 & 1 \end{pmatrix}$$$  $$$\begin{pmatrix} 0 & 0 & 0\\ 0 & 0 & 0 \end{pmatrix}$$$  $$$\begin{pmatrix} 1 & 0 & 1 & 1 & 1 & 1 & 1\\ 0 & 1 & 1 & 0 & 1 & 1 & 0\\ 1 & 1 & 1 & 1 & 1 & 0 & 1 \end{pmatrix}$$$

import Control.Monad
import Data.Array

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

routine :: IO ()
routine = do
  [n,m] <- (map read.words) <$> getLine
  rows <- replicateM n ((map read.words) <$> getLine)
  print $ solve n m rows

solve :: Int -> Int -> [[Int]] -> Int
solve n m rows = sum (map onepair pairs) {-+ if (n+m) `mod` 2 == 0 then f (diags!((n+m) `div` 2)) else 0-}
  where
    arr = listArray ((1,1),(n,m)) (concat rows)
    diags =listArray (1,n+m-1) [[ arr!(i,d+1-i) | i <- [1..d],i<=n,(d+1-i)<=m] | d <- [1..(n+m-1)]]
    pairs = [ diags!i ++ diags!(n+m-i) | i <- [1..((n+m-1) `div` 2)]]

onepair :: [Int] -> Int
onepair xs =uncurry min $ g (0,0) xs
  where
    g (z,o) (0:xss) = g (z+1,o) xss
    g (z,o) (1:xss) = g (z,o+1) xss
    g pa [] = pa
    g _ _ = undefined

f :: [Int] -> Int
f xs =(\x -> (x+1) `div` 2) $ sum $ map (\(x,y) -> if x == y then 0 else 1) $ zip xs (reverse xs)


Prefix function of string $$$t = t_1 t_2 \ldots t_n$$$ and position $$$i$$$ in it is defined as the length $$$k$$$ of the longest proper (not equal to the whole substring) prefix of substring $$$t_1 t_2 \ldots t_i$$$ which is also a suffix of the same substring.For example, for string $$$t = $$$ abacaba the values of the prefix function in positions $$$1, 2, \ldots, 7$$$ are equal to $$$[0, 0, 1, 0, 1, 2, 3]$$$.Let $$$f(t)$$$ be equal to the maximum value of the prefix function of string $$$t$$$ over all its positions. For example, $$$f($$$abacaba$$$) = 3$$$.You are given a string $$$s$$$. Reorder its characters arbitrarily to get a string $$$t$$$ (the number of occurrences of any character in strings $$$s$$$ and $$$t$$$ must be equal). The value of $$$f(t)$$$ must be minimized. Out of all options to minimize $$$f(t)$$$, choose the one where string $$$t$$$ is the lexicographically smallest.

Each test contains multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \le t \le 10^5$$$). Description of the test cases follows. The only line of each test case contains string $$$s$$$ ($$$1 \le |s| \le 10^5$$$) consisting of lowercase English letters. It is guaranteed that the sum of lengths of $$$s$$$ over all test cases does not exceed $$$10^5$$$.

For each test case print a single string $$$t$$$. The multisets of letters in strings $$$s$$$ and $$$t$$$ must be equal. The value of $$$f(t)$$$, the maximum of prefix functions in string $$$t$$$, must be as small as possible. String $$$t$$$ must be the lexicographically smallest string out of all strings satisfying the previous conditions.

NoteA string $$$a$$$ is lexicographically smaller than a string $$$b$$$ if and only if one of the following holds: $$$a$$$ is a prefix of $$$b$$$, but $$$a \ne b$$$; in the first position where $$$a$$$ and $$$b$$$ differ, the string $$$a$$$ has a letter that appears earlier in the alphabet than the corresponding letter in $$$b$$$.In the first test case, $$$f(t) = 0$$$ and the values of prefix function are $$$[0, 0, 0, 0, 0]$$$ for any permutation of letters. String ckpuv is the lexicographically smallest permutation of letters of string vkcup.In the second test case, $$$f(t) = 1$$$ and the values of prefix function are $$$[0, 1, 0, 1, 0, 1, 0]$$$.In the third test case, $$$f(t) = 5$$$ and the values of prefix function are $$$[0, 1, 2, 3, 4, 5]$$$.

import Control.Arrow ((>>>))
import Data.List (sort)

main :: IO ()
main = interact $ lines >>> drop 1 >>> map solve >>> unlines

solve :: String -> String
solve s
  | null fs = s
  | not (null fs1) = let o = fst (head fs1) in o : filter (/= o) (suf $ (a, fa) : fs)
  | fa <= 2 = repl fa a ++ suf fs
  | fa - 2 <= n - fa = a : interleave (repl (fa - 1) a) (suf fs)
  | length fs == 1 = a : suf fs ++ repl (fa - 1) a
  | otherwise = case fs of
    (b, fb) : (c, fc) : fs' ->
      a : b : suf ((a, fa - 1) : (c, 1) : (b, fb - 1) : (c, fc - 1) : fs')
  where
    n = length s
    (a, fa) : fs = [(c, f) | c <- ['a' .. 'z'], let f = count c s, f > 0]
    fs1 = filter ((== 1) . snd) $ (a, fa) : fs
    suf = concatMap (uncurry (flip repl))

interleave :: [a] -> [a] -> [a]
interleave [] ys = ys
interleave (x : xs) ys = x : interleave ys xs

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

repl = replicate

{-# LANGUAGE LambdaCase #-}

import Control.Applicative (liftA2)
import Control.Monad (replicateM)
import Control.Monad.State (State, evalState, get, gets, put)
import qualified Data.ByteString.Lazy.Char8 as C
import Data.List (sort)
import Data.Maybe (fromJust)

main :: IO ()
-- main = C.interact $ runScanner (C.pack <$> testCase)
main = C.interact $ runScanner (C.unlines <$> numberOf testCase)

type Str = C.ByteString

testCase :: Scanner Str
testCase = C.pack . solve <$> bstr

solve :: Str -> String
solve s
  | null fs = C.unpack s
  | not (null fs1) = let o = fst (head fs1) in o : filter (/= o) (suf $ (a, fa):fs)
  | fa <= 2 = repl fa a ++ suf fs
  | fa - 2 <= n - fa = a : interleave (repl (fa - 1) a) (suf fs)
  | length fs == 1 = a : suf fs ++ repl (fa - 1) a
  | otherwise = case fs of
    (b, fb) : (c, fc) : fs' ->
      a : b : suf ((a, fa - 1) : (c, 1) : (b, fb - 1) : (c, fc - 1) : fs')
  where
    n = fi $ C.length s
    (a, fa) : fs = [(c, fi f) | c <- ['a' .. 'z'], let f = C.count c s, f > 0]
    fs1 = filter ((== 1) . snd) $ (a, fa) : fs
    suf = concatMap (uncurry (flip repl))

interleave :: [a] -> [a] -> [a]
interleave [] ys = ys
interleave (x : xs) ys = x : interleave ys xs

fi = fromIntegral
repl = replicate

-------------------------- Template ------------------------------------------
type Scanner = State [C.ByteString]

runScanner :: Scanner a -> C.ByteString -> a
runScanner = runScannerWith C.words

runScannerWith :: (C.ByteString -> [C.ByteString]) -> Scanner a -> C.ByteString -> a
runScannerWith t s = evalState s . t

peek :: Scanner C.ByteString
peek = gets head

bstr :: Scanner C.ByteString
bstr = get >>= \case s : ss -> put ss >> return s

str :: Scanner String
str = C.unpack <$> bstr

int :: Scanner Int
int = fst . fromJust . C.readInt <$> bstr

integer :: Scanner Integer
integer = read . C.unpack <$> bstr

double :: Scanner Double
double = read . C.unpack <$> bstr

decimal :: Int -> Scanner Int
decimal p = round . ((10 ^ p) *) <$> double

numberOf :: Scanner a -> Scanner [a]
numberOf s = int >>= flip replicateM s

many :: Scanner a -> Scanner [a]
many s = get >>= \case [] -> return []; _ -> (:) <$> s <*> many s

till :: (C.ByteString -> Bool) -> Scanner a -> Scanner [a]
till p s = do
  t <- peek
  if p t
    then return []
    else (:) <$> s <*> till p s

times :: Int -> Scanner a -> Scanner [a]
times = replicateM

(><) = times

two, three, four :: Scanner a -> Scanner [a]
[two, three, four] = map times [2 .. 4]

pair :: Scanner a -> Scanner b -> Scanner (a, b)
pair = liftA2 (,)

{-# LANGUAGE BangPatterns #-}

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

import Data.Array.Unboxed
import Data.Array.ST.Safe

type UAC = UArray Char Int

isOK :: UAC -> Char -> Char -> Char -> Bool
isOK cts c1 c2 prev = if  c1 == c2
  then  let
  n = foldl' (+) 0 $ elems cts
  needed = if  c1 == prev  then  2 * cts ! c1  else  2 * cts ! c1 - 1
  in  n >= needed
  else  c1 /= prev || cts ! c2 == 0
  || or [ct > 0 | (c, ct) <- assocs cts, c /= c1 && c /= c2]

nextC :: UAC -> Char -> Char -> Char -> Char
nextC cts c1 c2 prev = head $ do
  (curr, ct) <- assocs cts
  guard $ ct > 0 -- can use char
  guard $ prev /= c1 || curr /= c2 -- no immediate issue
  guard $ isOK (cts // [(curr, ct - 1)]) c1 c2 curr -- no later issue
  pure curr

step :: Char -> Char -> (UAC, Int, Char) -> Maybe (Char, (UAC, Int, Char))
step _ _ (_, 0, _) = Nothing
step c1 c2 (!cts, !n, !prev) = let
  curr = nextC cts c1 c2 prev
  in  Just (curr, (cts // [(curr, cts ! curr - 1)], n - 1, curr))

concatArr :: UAC -> String
concatArr arr = do
  (c, ct) <- assocs arr
  replicate ct c

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [t] <- readInts
  replicateM_ t $ do
    s <- readLine
    let
      cts :: UAC
      cts = runSTUArray $ do
        arr <- newArray ('a', 'z') 0
        (\fun -> arr <$ P.foldr fun (pure ()) s) $ \c act -> do
          v <- readArray arr c
          writeArray arr c (v + 1)
          act
      n = foldl' (+) 0 $ elems cts
      uniqs = [c | (c, 1) <- assocs cts]
      ans = case  uniqs  of
        c : _ -> c : concatArr (cts // [(c, 0)])
        [] -> let
          present = [c | (c, ct) <- assocs cts, ct > 0]
          in  case  present  of
          [] -> error "empty input?"
          [c] -> replicate n c
          c1 : _ -> let
            rcts = cts // [(c1, cts ! c1 - 1)]
            c2 = head [c | (c, ct) <- assocs rcts, ct > 0,
                       isOK (rcts // [(c, ct - 1)]) c1 c c]
            nrcts = rcts // [(c2, rcts ! c2 - 1)]
            in  c1 : c2 : unfoldr (step c1 c2) (nrcts, n - 2, c2)
    lift $ B.hPutBuilder stdout $ B.string7 ans <> B.char7 '\n'

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]

{-# LANGUAGE LambdaCase #-}

import Control.Applicative (liftA2)
import Control.Monad (replicateM)
import Control.Monad.State (State, evalState, get, gets, put)
import qualified Data.ByteString.Lazy.Char8 as C
import Data.List (sort)
import Data.Maybe (fromJust)

main :: IO ()
-- main = C.interact $ runScanner (C.pack <$> testCase)
main = C.interact $ runScanner (C.unlines <$> numberOf testCase)

type Str = C.ByteString

testCase :: Scanner Str
testCase = C.pack . solve <$> bstr

solve :: Str -> String
solve s
  | null fs = C.unpack s
  | fa <= 2 = repl fa a ++ suf fs
  | fa - 2 <= n - fa = a : interleave (repl (fa - 1) a) (suf fs)
  | length fs == 1 = a : suf fs ++ repl (fa - 1) a
  | otherwise = case fs of
    (b, fb) : (c, fc) : fs' ->
      a : b : suf ((a, fa - 1) : (c, 1) : (b, fb - 1) : (c, fc - 1) : fs')
  where
    n = fi $ C.length s
    (a, fa) : fs = sort [(c, fi f) | c <- ['a' .. 'z'], let f = C.count c s, f > 0]
    suf = concatMap (\(c, f) -> repl f c)

interleave :: [a] -> [a] -> [a]
interleave [] ys = ys
interleave (x : xs) ys = x : interleave ys xs

fi = fromIntegral
repl = replicate

-------------------------- Template ------------------------------------------
type Scanner = State [C.ByteString]

runScanner :: Scanner a -> C.ByteString -> a
runScanner = runScannerWith C.words

runScannerWith :: (C.ByteString -> [C.ByteString]) -> Scanner a -> C.ByteString -> a
runScannerWith t s = evalState s . t

peek :: Scanner C.ByteString
peek = gets head

bstr :: Scanner C.ByteString
bstr = get >>= \case s : ss -> put ss >> return s

str :: Scanner String
str = C.unpack <$> bstr

int :: Scanner Int
int = fst . fromJust . C.readInt <$> bstr

integer :: Scanner Integer
integer = read . C.unpack <$> bstr

double :: Scanner Double
double = read . C.unpack <$> bstr

decimal :: Int -> Scanner Int
decimal p = round . ((10 ^ p) *) <$> double

numberOf :: Scanner a -> Scanner [a]
numberOf s = int >>= flip replicateM s

many :: Scanner a -> Scanner [a]
many s = get >>= \case [] -> return []; _ -> (:) <$> s <*> many s

till :: (C.ByteString -> Bool) -> Scanner a -> Scanner [a]
till p s = do
  t <- peek
  if p t
    then return []
    else (:) <$> s <*> till p s

times :: Int -> Scanner a -> Scanner [a]
times = replicateM

(><) = times

two, three, four :: Scanner a -> Scanner [a]
[two, three, four] = map times [2 .. 4]

pair :: Scanner a -> Scanner b -> Scanner (a, b)
pair = liftA2 (,)

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Strict #-}

import Control.Applicative (liftA2)
import Control.Monad (replicateM)
import Control.Monad.State (State, evalState, get, gets, put)
import qualified Data.ByteString.Lazy.Char8 as C
import Data.List (sort)
import Data.Maybe (fromJust)

main :: IO ()
-- main = C.interact $ runScanner (C.pack <$> testCase)
main = C.interact $ runScanner (C.unlines <$> numberOf testCase)

type Str = C.ByteString

testCase :: Scanner Str
testCase = solve <$> bstr

solve :: Str -> Str
solve s
  | null fs = s
  | fa <= 2 = C.pack $ repl fa a ++ suf
  | fa - 2 > n - fa = C.pack $ interleave (repl fa a) suf
  | otherwise = C.pack $ 'a' : interleave (repl (fa - 1) a) suf
  where
    n = fi $ C.length s
    (a, fa) : fs = sort [(c, fi $ C.count c s) | c <- ['a' .. 'z']]
    suf = concatMap (\(c, f) -> repl f c) fs
    interleave [] ys = ys
    interleave (x : xs) ys = x : interleave ys xs

fi = fromIntegral
repl = replicate

-------------------------- Template ------------------------------------------
type Scanner = State [C.ByteString]

runScanner :: Scanner a -> C.ByteString -> a
runScanner = runScannerWith C.words

runScannerWith :: (C.ByteString -> [C.ByteString]) -> Scanner a -> C.ByteString -> a
runScannerWith t s = evalState s . t

peek :: Scanner C.ByteString
peek = gets head

bstr :: Scanner C.ByteString
bstr = get >>= \case s : ss -> put ss >> return s

str :: Scanner String
str = C.unpack <$> bstr

int :: Scanner Int
int = fst . fromJust . C.readInt <$> bstr

integer :: Scanner Integer
integer = read . C.unpack <$> bstr

double :: Scanner Double
double = read . C.unpack <$> bstr

decimal :: Int -> Scanner Int
decimal p = round . ((10 ^ p) *) <$> double

numberOf :: Scanner a -> Scanner [a]
numberOf s = int >>= flip replicateM s

many :: Scanner a -> Scanner [a]
many s = get >>= \case [] -> return []; _ -> (:) <$> s <*> many s

till :: (C.ByteString -> Bool) -> Scanner a -> Scanner [a]
till p s = do
  t <- peek
  if p t
    then return []
    else (:) <$> s <*> till p s

times :: Int -> Scanner a -> Scanner [a]
times = replicateM

(><) = times

two, three, four :: Scanner a -> Scanner [a]
[two, three, four] = map times [2 .. 4]

pair :: Scanner a -> Scanner b -> Scanner (a, b)
pair = liftA2 (,)

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Strict #-}

import Control.Applicative (liftA2)
import Control.Monad (replicateM)
import Control.Monad.State (State, evalState, get, gets, put)
import qualified Data.ByteString.Lazy.Char8 as C
import Data.List (sort)
import Data.Maybe (fromJust)

main :: IO ()
-- main = C.interact $ runScanner (C.pack <$> testCase)
main = C.interact $ runScanner (C.unlines <$> numberOf testCase)

type Str = C.ByteString

testCase :: Scanner Str
testCase = solve <$> bstr

solve :: Str -> Str
solve s
  | null fs = s
  | fa <= 2 = C.pack $ repl fa a ++ suf
  | otherwise = C.pack $ 'a' : interleave (repl (fa - 1) a) suf
  where
    (a, fa) : fs = sort [(c, C.count c s) | c <- ['a' .. 'z']]
    suf = concatMap (\(c, f) -> repl f c) fs
    repl n x = replicate (fromIntegral n) x
    interleave [] ys = ys
    interleave (x : xs) ys = x : interleave ys xs

-------------------------- Template ------------------------------------------
type Scanner = State [C.ByteString]

runScanner :: Scanner a -> C.ByteString -> a
runScanner = runScannerWith C.words

runScannerWith :: (C.ByteString -> [C.ByteString]) -> Scanner a -> C.ByteString -> a
runScannerWith t s = evalState s . t

peek :: Scanner C.ByteString
peek = gets head

bstr :: Scanner C.ByteString
bstr = get >>= \case s : ss -> put ss >> return s

str :: Scanner String
str = C.unpack <$> bstr

int :: Scanner Int
int = fst . fromJust . C.readInt <$> bstr

integer :: Scanner Integer
integer = read . C.unpack <$> bstr

double :: Scanner Double
double = read . C.unpack <$> bstr

decimal :: Int -> Scanner Int
decimal p = round . ((10 ^ p) *) <$> double

numberOf :: Scanner a -> Scanner [a]
numberOf s = int >>= flip replicateM s

many :: Scanner a -> Scanner [a]
many s = get >>= \case [] -> return []; _ -> (:) <$> s <*> many s

till :: (C.ByteString -> Bool) -> Scanner a -> Scanner [a]
till p s = do
  t <- peek
  if p t
    then return []
    else (:) <$> s <*> till p s

times :: Int -> Scanner a -> Scanner [a]
times = replicateM

(><) = times

two, three, four :: Scanner a -> Scanner [a]
[two, three, four] = map times [2 .. 4]

pair :: Scanner a -> Scanner b -> Scanner (a, b)
pair = liftA2 (,)

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

import Data.Array.Unboxed
import Data.Array.ST.Safe

bucketSort :: (Char, Char) -> P.ByteString -> (Int, String, UArray Char Int)
bucketSort bnds s = let
  counts :: UArray Char Int
  counts = runSTUArray $ do
    arr <- newArray bnds 0
    (\fun -> arr <$ P.foldr fun (pure ()) s) $ \c act -> do
      v <- readArray arr c
      writeArray arr c (v + 1)
      act
  n = foldl' (+) 0 $ elems counts
  ss = do
    (c, ct) <- assocs $ counts
    replicate ct c
  in  (n, ss, counts)

go :: String -> String -> String -> String
go [] xs ys = xs ++ ys
go as xs [] = xs ++ as
go (a:as) xs (y:ys) = a : y : go as xs ys

solve :: String -> String -> String -> String
solve as [] [] = as
solve (a:as) (x:xs) ys = a : x : go as xs ys
solve _ _ _ = error "yikes"

go2 :: String -> String -> String
go2 [] xs = xs
go2 [a] [] = [a]
go2 (a : as) (x : xs) = a : x : go2 as xs
go2 _ _ = error "yikes2:go"

solve2 :: String -> String -> String
solve2 [] [] = []
solve2 (a : as) xs = a : go2 as xs
solve2 _ _ = error "yikes2"

solve1 :: UArray Char Int -> Maybe String
solve1 arr = case  [c | (c, 1) <- assocs arr]  of
  [] -> Nothing
  c : _ -> Just $ c : do
    (cc, ct) <- assocs arr
    guard $ cc /= c
    replicate ct cc

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [t] <- readInts
  replicateM_ t $ do
    s <- readLine
    let
      (n, w, cts) = bucketSort ('a', 'z') s
      tarc = head w
      key : unsa : sau = group w ++ replicate 3 []
      sa = concat sau
      ans = case  solve1 cts  of
        Just v -> v
        Nothing -> if  2 * (cts ! tarc - 1) > n
          then  solve  key unsa sa
          else  solve2 key (unsa ++ sa)
    lift $ B.hPutBuilder stdout $ B.string7 ans <> B.char7 '\n'

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]

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

import Data.Array.Unboxed
import Data.Array.ST.Safe

bucketSort :: (Char, Char) -> P.ByteString -> (Int, String, UArray Char Int)
bucketSort bnds s = let
  counts :: UArray Char Int
  counts = runSTUArray $ do
    arr <- newArray bnds 0
    (\fun -> arr <$ P.foldr fun (pure ()) s) $ \c act -> do
      v <- readArray arr c
      writeArray arr c (v + 1)
      act
  n = foldl' (+) 0 $ elems counts
  ss = do
    (c, ct) <- assocs $ counts
    replicate ct c
  in  (n, ss, counts)

go :: String -> String -> String -> String
go [] xs ys = xs ++ ys
go as xs [] = xs ++ as
go (a:as) xs (y:ys) = a : y : go as xs ys

solve :: String -> String -> String -> String
solve as [] [] = as
solve (a:as) (x:xs) ys = a : x : go as xs ys
solve _ _ _ = error "yikes"

go2 :: String -> String -> String
go2 [] xs = xs
go2 [a] [] = [a]
go2 (a : as) (x : xs) = a : x : go2 as xs
go2 _ _ = error "yikes2:go"

solve2 :: String -> String -> String
solve2 [] [] = []
solve2 (a : as) xs = a : go2 as xs
solve2 _ _ = error "yikes2"

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [t] <- readInts
  replicateM_ t $ do
    s <- readLine
    let
      (n, w, cts) = bucketSort ('a', 'z') s
      tarc = head w
      key : unsa : sau = group w ++ replicate 3 []
      sa = concat sau
      ans = if  2 * (cts ! tarc - 1) > n
        then  solve  key unsa sa
        else  solve2 key (unsa ++ sa)
    lift $ B.hPutBuilder stdout $ B.string7 ans <> B.char7 '\n'

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]