One day Anna got the following task at school: to arrange several numbers in a circle so that any two neighboring numbers differs exactly by 1. Anna was given several numbers and arranged them in a circle to fulfill the task. Then she wanted to check if she had arranged the numbers correctly, but at this point her younger sister Maria came and shuffled all numbers. Anna got sick with anger but what's done is done and the results of her work had been destroyed. But please tell Anna: could she have hypothetically completed the task using all those given numbers?

The first line contains an integer n — how many numbers Anna had (3 ≤ n ≤ 105). The next line contains those numbers, separated by a space. All numbers are integers and belong to the range from 1 to 109.

Print the single line "YES" (without the quotes), if Anna could have completed the task correctly using all those numbers (using all of them is necessary). If Anna couldn't have fulfilled the task, no matter how hard she would try, print "NO" (without the quotes).

import Data.List

type Counter = Int
type Value = Int

dataList :: [String] -> [(Value,Counter)]
dataList = map f .group.sort.map read
  where
    f as = (head as,length as)

judge :: [(Value,Counter)] -> Bool
judge xs = let ys = map snd xs
           in check xs &&
               myfoldl (head ys) (tail ys)

myfoldl :: Counter -> [Counter] -> Bool
myfoldl x [y] = y-x == 0
myfoldl x (y:xs) = if y-x <= 0 then False
                               else myfoldl (y-x) xs

check :: [(Value,Counter)] -> Bool
check [_] = True
check (x:y:xs) = if abs (fst x - fst y) == 1
                        then check (y:xs)
                        else False
{-
main = do _ <- getLine
          ls <- getLine
-}
main = do input <- getContents
          let (n:ls) = words input
          putStrLn.ans $ judge $ dataList$ take (read n) ls
  where
    ans True  = "YES"
    ans False = "NO"

main = do
  n <- getLine
  ls <- getLine
  print $ judge $
    arrange ([head $ list ls],tail $ list ls)
            (read n, product [1..read n])
  where
    list = map read.words

    judge True = "YES"
    judge False = "NO"

arrange :: ([Int],[Int]) -> (Int,Int) -> Bool
arrange _ (n,0) = False
arrange (as,[b]) _    = last as `equal1` b
arrange (as,[]) (n,_) = n==length as
arrange (as,b:bs) (n,k)
  = if head as `equal1` b
      then arrange ((b:as),bs) (n,k-1)
      else arrange (as,bs++[b])  (n,k-1)

equal1 a b = (==1).abs $ a-b

main = do
  n <- getLine
  ls <- getLine
  putStrLn $ judge $
    arrange ([head $ list ls],tail $ list ls)
            (read n, product [1..read n])
  where
    list = map read.words

    judge True = "YES"
    judge False = "NO"

arrange :: ([Int],[Int]) -> (Int,Int) -> Bool
arrange _ (n,-1) = False
arrange (as,[b]) _    = last as `equal1` b && head as `equal1` b
--arrange (as,[]) (n,_) = n==length as
arrange (as,b:bs) (n,k)
  = if head as `equal1` b
      then arrange ((b:as),bs) (n,k-1)
      else arrange (as,bs++[b])  (n,k-1)

equal1 a b = (==1).abs $ a-b

main = do
  n <- getLine
  ls <- getLine
  putStrLn $ judge $
    arrange ([head $ list ls],tail $ list ls)
            (read n, product [1..read n])
  where
    list = map read.words

    judge True = "YES"
    judge False = "NO"

arrange :: ([Int],[Int]) -> (Int,Int) -> Bool
arrange _ (n,0) = False
arrange (as,[b]) _    = last as `equal1` b
arrange (as,[]) (n,_) = n==length as
arrange (as,b:bs) (n,k)
  = if head as `equal1` b
      then arrange ((b:as),bs) (n,k-1)
      else arrange (as,bs++[b])  (n,k-1)

equal1 a b = (==1).abs $ a-b

import Data.List

type Counter = Int
type Value = Int

dataList :: [String] -> [(Value,Counter)]
dataList = map f .group.sort.map read
  where
    f as = (head as,length as)

judge :: [(Value,Counter)] -> Bool
judge xs = let ys = map snd xs
           in check xs &&
               0 == foldl (flip (-)) (head ys) (tail ys)

check :: [(Value,Counter)] -> Bool
check [_] = True
check (x:y:xs) = if abs (fst x - fst y) == 1
                        then check (y:xs)
                        else False
{-
main = do _ <- getLine
          ls <- getLine
-}
main = do input <- getContents
          let (n:ls) = words input
          putStrLn.ans $ judge $ dataList$ take (read n) ls
  where
    ans True  = "YES"
    ans False = "NO"

import Data.List

type Counter = Int
type Value = Int

dataList :: [String] -> [(Value,Counter)]
dataList = map f .group.sort.map read
  where
    f as = (head as,length as)

judge :: [(Value,Counter)] -> Bool
judge xs = let ys = map snd xs
           in check xs &&
               myfoldl (head ys) (tail ys)

myfoldl :: Counter -> [Counter] -> Bool
myfoldl x [y] = y-x == 0
myfoldl x (y:xs) = if y-x == 0 then False
                               else myfoldl (y-x) xs

check :: [(Value,Counter)] -> Bool
check [_] = True
check (x:y:xs) = if abs (fst x - fst y) == 1
                        then check (y:xs)
                        else False
{-
main = do _ <- getLine
          ls <- getLine
-}
main = do input <- getContents
          let (n:ls) = words input
          putStrLn.ans $ judge $ dataList$ take (read n) ls
  where
    ans True  = "YES"
    ans False = "NO"


Suppose $$$a_1, a_2, \dots, a_n$$$ is a sorted integer sequence of length $$$n$$$ such that $$$a_1 \leq a_2 \leq \dots \leq a_n$$$. For every $$$1 \leq i \leq n$$$, the prefix sum $$$s_i$$$ of the first $$$i$$$ terms $$$a_1, a_2, \dots, a_i$$$ is defined by $$$$$$ s_i = \sum_{k=1}^i a_k = a_1 + a_2 + \dots + a_i. $$$$$$Now you are given the last $$$k$$$ terms of the prefix sums, which are $$$s_{n-k+1}, \dots, s_{n-1}, s_{n}$$$. Your task is to determine whether this is possible. Formally, given $$$k$$$ integers $$$s_{n-k+1}, \dots, s_{n-1}, s_{n}$$$, the task is to check whether there is a sequence $$$a_1, a_2, \dots, a_n$$$ such that   $$$a_1 \leq a_2 \leq \dots \leq a_n$$$, and  $$$s_i = a_1 + a_2 + \dots + a_i$$$ for all $$$n-k+1 \leq i \leq n$$$.

Each test contains multiple test cases. The first line contains an integer $$$t$$$ ($$$1 \leq t \leq 10^5$$$) — the number of test cases. The following lines contain the description of each test case. The first line of each test case contains two integers $$$n$$$ ($$$1 \leq n \leq 10^5$$$) and $$$k$$$ ($$$1 \leq k \leq n$$$), indicating the length of the sequence $$$a$$$ and the number of terms of prefix sums, respectively. The second line of each test case contains $$$k$$$ integers $$$s_{n-k+1}, \dots, s_{n-1}, s_{n}$$$ ($$$-10^9 \leq s_i \leq 10^9$$$ for every $$$n-k+1 \leq i \leq n$$$). It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$10^5$$$.

For each test case, output "YES" (without quotes) if it is possible and "NO" (without quotes) otherwise. You can output "YES" and "NO" in any case (for example, strings "yEs", "yes" and "Yes" will be recognized as a positive response).

NoteIn the first test case, we have the only sequence $$$a = [1, 1, 1, 1, 1]$$$.In the second test case, we can choose, for example, $$$a = [-3, -2, -1, 0, 1, 2, 3]$$$.In the third test case, the prefix sums define the only sequence $$$a = [2, 1, 1]$$$, but it is not sorted. In the fourth test case, it can be shown that there is no sequence with the given prefix sums.

{-# LANGUAGE OverloadedStrings #-}

import Control.Monad
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Internal as BSI
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Maybe

main =
  cf $ do
    [n, k] <- readInts
    nums <- readInts
    let hn = head nums
        v1 = (nums !! 1) - head nums
        dh = n - k + 1
        p =
          if k < 2
            then True
            else hn - v1 * dh <= 0
        diffs =
          zipWith3
            (\p c n -> (p - (2 * c) + n >= 0))
            nums
            (tail nums)
            (drop 2 nums)
        q = and diffs
    BS.putStrLn $
      if p && q
        then "Yes"
        else "No"

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

readInt :: IO Int
readInt = readLn

cf x = readInt >>= (`replicateM_` x)

import Control.Monad (replicateM_)
main = read <$> getLine >>= flip replicateM_ scase
scase = map read . words <$> getLine >>=
        \[n, k] -> map read . words <$> getLine >>=
        \ss -> putStrLn $ if possible n k ss then "YES" else "NO"

possible :: Int -> Int -> [Int] -> Bool
possible n k ss = let (finalTerms, _) = foldl (\(acc, s) s1 -> (s1-s:acc, s1))
                                        ([], head ss) (tail ss)
                      isSorted xs = all (\(x, y) -> x >= y) (zip xs (tail xs))
                      realizable n k maxTerm left = maxTerm*(n-k+1) >= left

                  in
                    if finalTerms == []
                    then True
                    else (isSorted finalTerms) &&
                         (realizable n k (last finalTerms) (head ss))

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

import Control.Applicative (liftA2)
import Control.Arrow ((>>>))
import Control.Monad
import Control.Monad.State (State, evalState, get, gets, put)
import Data.Bool
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Function
import Data.Int
import Data.List
import Data.Maybe
import Debug.Trace

----- Solution
data TC = TC {n :: Int64, k :: Int64, ss :: [Int64]}

type Output = Bool

input :: Scanner TC
input = do
  n <- int64
  k <- int64
  ss <- (fromIntegral k :: Int) >< int64
  return TC {..}

solve :: TC -> Output
solve TC {..} = sorted as && (null as || head as * (n - k + 1) >= head ss)
  where
    as = zipWith (-) (tail ss) ss

sorted :: Ord a => [a] -> Bool
sorted xs = and $ zipWith (<=) xs (tail xs)

output :: Int -> Output -> C.ByteString
output _ = showYesNo

main :: IO ()
main = C.interact $ runScanner (numberOf input) >>> map solve >>> zip [1 ..] >>> map (uncurry output) >>> C.unlines

-------------------------- Template ------------------------------------------
-- Debug
debug :: Show a => a -> a
debug a = trace (show a) a

-- helpers
(>$>) = flip ($)

infixl 0 >$>

-- Lists
groupOn :: Eq b => (a -> b) -> [a] -> [[a]]
groupOn = groupBy . on (==)

chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf k xs = let (hs, ts) = splitAt k xs in hs : chunksOf k ts

adjacents :: [a] -> [(a, a)]
adjacents xs = zip xs (tail xs)

adjacentsWith :: (a -> a -> b) -> [a] -> [b]
adjacentsWith f xs = zipWith f xs (tail xs)

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

countBy :: (a -> Bool) -> [a] -> Int
countBy p = length . filter p

-- Scanner
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

readStr :: Read a => Scanner a
readStr = read <$> str

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

integer :: Scanner Integer
integer = readStr

int64 :: Scanner Int64
int64 = readStr

double :: Scanner Double
double = readStr

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 (,)

showB :: Show a => a -> C.ByteString
showB = C.pack . show

showYesNo :: Bool -> C.ByteString
showYesNo = bool "NO" "YES" >>> C.pack

import Control.Monad

toShow True = "YES"
toShow False = "NO"

solve n m = (div (n+1) 2,div (m+1) 2)

isAsc (x:y:xs) = x<=y && isAsc (y:xs)
isAsc _ = True

main :: IO ()
main = do
    ts <- getLine
    replicateM (read ts::Int) $ do
        input <- getLine
        let [n,k] = map read . words $ input ::[Integer]
        input <- getLine
        let s = map read . words $ input ::[Integer]
        let a = zipWith (-) (tail s) s
        putStrLn.toShow $ (isAsc a && (a==[] || (head s) <= (n-k+1)*head a))
    return ()

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

solve _ [_] = True
solve n ps = sorted && head ps <= mxsum where
  xs = zipWith (-) (tail ps) ps
  sorted = and $ zipWith (<=) xs (tail xs)
  mxsum = head xs * (n - length xs)

yesno True = "Yes"
yesno False = "No"

main = do
  [t] <- readInts
  replicateM_ t $
    solve . head <$> readInts <*> readInts >>= putStrLn . yesno

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

{-# LANGUAGE OverloadedStrings #-}

import Control.Monad
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Internal as BSI
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Maybe

main =
  cf $ do
    [n, k] <- readInts
    nums' <- readInts
    let nums = drop (n - k) (0 : nums')
        diffs =
          zipWith3
            (\p c n -> (p - (2 * c) + n >= 0))
            nums
            (tail nums)
            (drop 2 nums)
        q = and diffs
    BS.putStrLn $
      if q
        then "Yes"
        else "No"

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

readInt :: IO Int
readInt = readLn

cf x = readInt >>= (`replicateM_` x)

{-# LANGUAGE OverloadedStrings #-}

import Control.Monad
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Internal as BSI
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Maybe

main =
  cf $ do
    [a, b] <- readInts
    nums <- readInts
    let diffs =
          zipWith3
            (\p c n -> (p - (2 * c) + n >= 0))
            (0 : nums)
            nums
            (tail nums)
        q = and diffs
    BS.putStrLn $
      if q
        then "Yes"
        else "No"

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

readInt :: IO Int
readInt = readLn

cf x = readInt >>= (`replicateM_` x)

import Control.Monad (replicateM_)
main = read <$> getLine >>= flip replicateM_ scase
scase = map read . words <$> getLine >>=
        \[n, k] -> map read . words <$> getLine >>=
        \ss -> putStrLn $ if possible n k ss then "YES" else "NO"

possible :: Int -> Int -> [Int] -> Bool
possible n k ss = let (finalTerms, _) = foldl (\(acc, s) s1 -> (s1-s:acc, s1))
                                        ([], head ss) (tail ss)
                      isSorted xs = all (\(x, y) -> x >= y) (zip xs (tail xs))
                      realizable n k maxTerm left | n == k = maxTerm >= left
                                                  | otherwise = maxTerm*(n-k) >= left

                  in
                    if finalTerms == []
                    then True
                    else (isSorted finalTerms) &&
                         (realizable n k (last finalTerms) (head ss))

import Control.Monad

toShow True = "YES"
toShow False = "NO"

solve n m = (div (n+1) 2,div (m+1) 2)

isAsc (x:y:xs) = x<=y && isAsc (y:xs)
isAsc _ = True

main :: IO ()
main = do
    ts <- getLine
    replicateM (read ts::Int) $ do
        input <- getLine
        let [n,k] = map read . words $ input ::[Integer]
        input <- getLine
        let s = map read . words $ input ::[Integer]
        let a = zipWith (-) (tail s) s
        putStrLn .show$a
        putStrLn.toShow $ (isAsc a && (a==[] || (head s) <= (n-k+1)*head a))
    return ()


You are given a string $$$s[1 \dots n]$$$ consisting of lowercase Latin letters. It is guaranteed that $$$n = 2^k$$$ for some integer $$$k \ge 0$$$.The string $$$s[1 \dots n]$$$ is called $$$c$$$-good if at least one of the following three conditions is satisfied:  The length of $$$s$$$ is $$$1$$$, and it consists of the character $$$c$$$ (i.e. $$$s_1=c$$$); The length of $$$s$$$ is greater than $$$1$$$, the first half of the string consists of only the character $$$c$$$ (i.e. $$$s_1=s_2=\dots=s_{\frac{n}{2}}=c$$$) and the second half of the string (i.e. the string $$$s_{\frac{n}{2} + 1}s_{\frac{n}{2} + 2} \dots s_n$$$) is a $$$(c+1)$$$-good string;  The length of $$$s$$$ is greater than $$$1$$$, the second half of the string consists of only the character $$$c$$$ (i.e. $$$s_{\frac{n}{2} + 1}=s_{\frac{n}{2} + 2}=\dots=s_n=c$$$) and the first half of the string (i.e. the string $$$s_1s_2 \dots s_{\frac{n}{2}}$$$) is a $$$(c+1)$$$-good string. For example: "aabc" is 'a'-good, "ffgheeee" is 'e'-good.In one move, you can choose one index $$$i$$$ from $$$1$$$ to $$$n$$$ and replace $$$s_i$$$ with any lowercase Latin letter (any character from 'a' to 'z').Your task is to find the minimum number of moves required to obtain an 'a'-good string from $$$s$$$ (i.e. $$$c$$$-good string for $$$c=$$$ 'a'). It is guaranteed that the answer always exists.You have to answer $$$t$$$ independent test cases.Another example of an 'a'-good string is as follows. Consider the string $$$s = $$$"cdbbaaaa". It is an 'a'-good string, because:  the second half of the string ("aaaa") consists of only the character 'a';  the first half of the string ("cdbb") is 'b'-good string, because:   the second half of the string ("bb") consists of only the character 'b';  the first half of the string ("cd") is 'c'-good string, because:   the first half of the string ("c") consists of only the character 'c';  the second half of the string ("d") is 'd'-good string.

The first line of the input contains one integer $$$t$$$ ($$$1 \le t \le 2 \cdot 10^4$$$) — the number of test cases. Then $$$t$$$ test cases follow. The first line of the test case contains one integer $$$n$$$ ($$$1 \le n \le 131~072$$$) — the length of $$$s$$$. It is guaranteed that $$$n = 2^k$$$ for some integer $$$k \ge 0$$$. The second line of the test case contains the string $$$s$$$ consisting of $$$n$$$ lowercase Latin letters. It is guaranteed that the sum of $$$n$$$ does not exceed $$$2 \cdot 10^5$$$ ($$$\sum n \le 2 \cdot 10^5$$$).

For each test case, print the answer — the minimum number of moves required to obtain an 'a'-good string from $$$s$$$ (i.e. $$$c$$$-good string with $$$c =$$$ 'a'). It is guaranteed that the answer exists.

6
8
bbdcaaaa
8
asdfghjk
8
ceaaaabb
8
bbaaddcc
1
z
2
ac

import Control.Monad ( replicateM_ )

cGood :: Char -> String -> Int
cGood c [x] = fromEnum (c /= x)
cGood c str = min (f a + g b) (g a + f b)
  where
    f = length . filter (/= c)
    g = cGood (succ c)
    (a, b) = splitAt (length str `div` 2) str

main :: IO ()
main = do
  n <- read <$> getLine
  replicateM_ n $ getLine >> getLine >>= print . cGood 'a'

import Data.List
import Control.Monad

notChar char xs = length $ filter (/= char) xs

good char [x]
  | x == char = True
  | otherwise = False
good char xs = (all (== char) start && good (succ char) end) || (all (== char) end && good (succ char) start)
  where
    (start, end) = splitAt n xs
    n = length xs `quot` 2

makeGood xs = go xs 'a' 0
  where
    go xs char m | good char xs = m
    go [x] char m = m + 1
    go xs char m = min (go end (succ char) (m + notChar char start)) (go start (succ char) (m + notChar char end))
      where
        (start, end) = splitAt n xs
        n = length xs `quot` 2

getTest :: IO String
getTest = do
  _ <- getLine
  getLine

main :: IO ()
main = do
  n <- getLine
  let n' = (read n :: Int)
  tests <- replicateM n' getTest
  mapM_ (print . makeGood) tests

import Data.List
import Control.Monad

data Half = Start | End deriving Show

notChar char xs = length $ filter (/= char) xs

mostHalf char xs = case nStart `compare` nEnd of
  GT -> Just Start
  LT -> Just End
  EQ -> Nothing
  where
    nStart = length $ filter (== char) start
    nEnd = length $ filter (== char) end

    (start, end) = splitAt n xs
    n = length xs `quot` 2

good char [x]
  | x == char = True
  | otherwise = False
good char xs = (all (== char) start && good (succ char) end) || (all (== char) end && good (succ char) start)
  where
    (start, end) = splitAt n xs
    n = length xs `quot` 2

makeGood xs = go xs 'a' 0
  where
    go xs char m | good char xs = m
    go [x] char m = m + 1
    go xs char m = case mostHalf char xs of
      Just Start -> go end (succ char) (m + notChar char start)
      Just End -> go start (succ char) (m + notChar char end)
      Nothing -> min (go end (succ char) (m + notChar char start)) (go start (succ char) (m + notChar char end))
      where
        (start, end) = splitAt n xs
        n = length xs `quot` 2

getTest :: IO String
getTest = do
  _ <- getLine
  getLine

main :: IO ()
main = do
  n <- getLine
  let n' = (read n :: Int)
  tests <- replicateM n' getTest
  mapM_ (print . makeGood) tests


According to Berland laws it is only allowed to sell alcohol to people not younger than 18 years. Vasya's job is to monitor the law's enforcement. Tonight he entered a bar and saw n people sitting there. For every one of them Vasya happened to determine either the age or the drink the person is having. Vasya can check any person, i.e. learn his age and the drink he is having at the same time. What minimal number of people should Vasya check additionally to make sure that there are no clients under 18 having alcohol drinks?The list of all alcohol drinks in Berland is: ABSINTH, BEER, BRANDY, CHAMPAGNE, GIN, RUM, SAKE, TEQUILA, VODKA, WHISKEY, WINE

The first line contains an integer n (1 ≤ n ≤ 100) which is the number of the bar's clients. Then follow n lines, each describing one visitor. A line either contains his age (an integer from 0 to 1000) or his drink (a string of capital Latin letters from 1 to 100 in length). It is guaranteed that the input data does not contain spaces and other unnecessary separators. Only the drinks from the list given above should be considered alcohol.

Print a single number which is the number of people Vasya should check to guarantee the law enforcement.

NoteIn the sample test the second and fifth clients should be checked.

module Main where

main
  = interact in2out

in2out input
  = output
  where
    output = show ans
    ans = count (<18) ages + count (\x->any (==x) alcohols) drinks
    ages = map (read::String->Int) [age | age@(x:xs)<-items, '0'<=x, x<='9']
    alcohols = ["ABSINTH", "BEER", "BRANDY", "CHAMPAGNE", "GIN", "RUM", "SAKE", "TEQUILA", "VODKA", "WHISKEY", "WINE"]
    drinks = items
    items = tail . lines $ input
    count f []
      = 0
    count f (x:xs)
      | f x
      = 1 + count f xs
      | otherwise
      = count f xs

main = do
n <- getLine >>= return . read
ls <- getContents >>= return . (take n) . lines
print $ sum $ map wrong ls where
wrong l = if (l!!0) <= '9'
 then if (read l) < 18 then 1 else 0
 else if l `elem` al then 1 else 0
al = "ABSINTH":"BEER":"BRANDY":"CHAMPAGNE":"GIN":"RUM":"SAKE":"TEQUILA":"VODKA":"WHISKEY":"WINE":[]

import Char

type Visitor = Either Int String

alcohols :: [String]
alcohols =  ["ABSINTH", "BEER",
             "BRANDY", "CHAMPAGNE",
             "GIN", "RUM",
             "SAKE", "TEQUILA",
             "VODKA", "WHISKEY",
             "WINE"]

checkVisitor :: Visitor -> Bool
checkVisitor (Left  age)    =  age < 18
checkVisitor (Right drink)  =  elem drink alcohols

parseVisitor :: String -> Visitor
parseVisitor line
  |  isDigit headLine  =  Left (read line)
  |  otherwise         =  Right line
  where
    headLine = head line

readVisitor :: Int -> IO Visitor
readVisitor _  =  getLine >>= return . parseVisitor

--readVisitor :: Int -> IO Visitor
--readVisitor _ = do
--  line <- getLine
--  return $ parseVisitor line

main :: IO()
main = do
  n <- readLn
  visitors <- sequence (map readVisitor [1..n])
  print $ length (filter checkVisitor visitors)

import Data.Char
import Data.List

solve = show.(foldl' f 0).tail.words
  where f ans ss | all isDigit ss = if (read ss) < 18 then
                                      ans + 1
                                    else
                                      ans
                 | otherwise      = if (ss `elem` alco) then
                                      ans + 1
                                    else
                                      ans
        alco = ["ABSINTH", "BEER", "BRANDY",
                "CHAMPAGNE", "GIN", "RUM",
                "SAKE", "TEQUILA", "VODKA",
                "WHISKEY", "WINE"]

main = interact solve

main=interact$show.sum.map f.tail.lines
f a=fromEnum$elem a$[show x|x<-[0..17]]++words"ABSINTH BEER BRANDY CHAMPAGNE GIN RUM SAKE TEQUILA VODKA WHISKEY WINE"

import Control.Monad
main = do
    n <- fmap read getLine
    ps <- forM [1..n] (\_ -> getLine)
    print $ solve ps
solve :: [String] -> Int
solve = foldl f 0
    where f :: Int -> String -> Int
          f n s = if elem s $ map show [0..1000] then if read s < 18 then n + 1
                                                                     else n
                                                 else if s `elem` alcohol then n + 1
                                                                          else n
alcohol :: [String]
alcohol = ["ABSINTH", "BEER", "BRANDY", "CHAMPAGNE", "GIN", "RUM", "SAKE", "TEQUILA", "VODKA", "WHISKEY", "WINE"]

import Prelude
import Data.Char
import Data.List
import Data.Functor

alc = words "ABSINTH BEER BRANDY CHAMPAGNE GIN RUM SAKE TEQUILA VODKA WHISKEY WINE"

main = interact q

q = func . tail . words

func::[String]->String
func x = case solve x of
           Just a -> show a
           Nothing-> "Error occurred"

fileInteract func inf ouf = do file <- readFile inf
                               writeFile ouf (func file)

toInt::String->Int
toInt = read

asInteger::String->Integer
asInteger = read

toString::Int->String
toString = show

reverseTuple::(a,b)->(b,a)
reverseTuple (a,b) = (b,a)

isVailed::String->Bool
isVailed "" = False
isVailed "0" = True
isVailed ('0':_) = False
isVailed _ = True

solve::[String]->Maybe Int
solve [] = Just 0
solve (x:xs) | isAlpha (x!!0) && x `elem` alc  = (+1) <$> solve xs
             | isDigit (x!!0) && (read x) < 18 = (+1) <$> solve xs
             | otherwise                       = solve xs

main = interact $ show . solve . tail . lines
solve = length . filter (\x -> elem x alc)
alc = ["ABSINTH", "BEER", "BRANDY", "CHAMPAGNE", "GIN", "RUM", "SAKE",
  "TEQUILA", "VODKA", "WHISKEY", "WINE"] ++ map show [0..17]

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}

import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.ByteString as SB
import Data.ByteString.Internal (inlinePerformIO)
import Foreign.C.String (CString)
import Foreign.C (CDouble)
import Data.Maybe
import Data.List (mapAccumL, sort, maximumBy, minimum, foldl')
import Data.Array
import qualified Data.Map as M
import qualified Data.IntMap as IM
import Debug.Trace
import Data.Function (on)
import Data.Ord (comparing)
import System.Random(mkStdGen, random)
import Data.Int(Int64)
import Data.Sequence (iterateN)

foreign import ccall unsafe "stdlib.h atof" c_atof :: CString -> IO Double
unsafeReadDouble = inlinePerformIO . flip SB.useAsCString c_atof
{-# INLINE unsafeReadDouble #-}
readDouble = unsafeReadDouble . SB.concat . LB.toChunks
readInt = fst . fromJust . LB.readInt

debug :: Show a => a -> a
debug v = trace (show v) v
--debug _ = id

main = do (sn:desc) <- fmap LB.lines LB.getContents
          let n = readInt sn
              desc' = map (head . LB.words) . take n $ desc
              f s = case LB.readInt s of
                      Just (m, _)    -> m<18
                      otherwise      -> s `elem` (map LB.pack ["ABSINTH", "BEER", "BRANDY", "CHAMPAGNE", "GIN", "RUM", "SAKE", "TEQUILA", "VODKA", "WHISKEY", "WINE"])

              c = length . filter f . take n $ desc'
          print c

import Prelude
import Data.Char
import Data.List
import Data.Functor

alc = words "ABSINTH BEER BRANDY CHAMPAGNE GIN RUM SAKE TEQUILA VODKA WHISKEY WINE"

main = interact q

q = func . init . words

func::[String]->String
func x = case solve x of
           Just a -> show a
           Nothing-> "Error occurred"

fileInteract func inf ouf = do file <- readFile inf
                               writeFile ouf (func file)

toInt::String->Int
toInt = read

asInteger::String->Integer
asInteger = read

toString::Int->String
toString = show

reverseTuple::(a,b)->(b,a)
reverseTuple (a,b) = (b,a)

isVailed::String->Bool
isVailed "" = False
isVailed "0" = True
isVailed ('0':_) = False
isVailed _ = True

solve::[String]->Maybe Int
solve [] = Just 0
solve (x:xs) | isAlpha (x!!0) && x `elem` alc  = (+1) <$> solve xs
             | isDigit (x!!0) && (read x) < 18 = (+1) <$> solve xs
             | otherwise                       = solve xs

import Prelude
import List
import Char

main = interact q

q = func.tail.lines

func::[String]->String
func = show.solve

fileInteract func inf ouf = do file <- readFile inf
                               writeFile ouf (func file)

toInt::String->Int
toInt = read

asInteger::String->Integer
asInteger = read

toString::Int->String
toString = show

solve::[String]->Int
solve (x:xs) | (isNumber x) && (((read::String->Int) x) < 18) = 1 + solve xs
             | (isAlc x)                                     = 1 + solve xs
             | otherwise                                     =     solve xs
               where
                isNumber (x:_) | '0' < x && x <='9' = True
                              | otherwise          = False
                isAlc x = x `elem`  ["ABSINTH", "BEER", "BRANDY", "CHAMPAGNE", "GIN", "RUM", "SAKE", "TEQUILA", "VODKA", "WHISKEY", "WINE"]
solve [] = 0

import Prelude
import Data.Char
import Data.List
import Data.Functor

alc = words "ABSINTH BEER BRANDY CHAMPAGNE GIN RUM SAKE TEQUILA VODKA WHISKEY WINE"

main = interact q

q = func . init . words

func::[String]->String
func x = case solve x of
           Just a -> show a
           Nothing-> "Error occurred"

fileInteract func inf ouf = do file <- readFile inf
                               writeFile ouf (func file)

toInt::String->Int
toInt = read

asInteger::String->Integer
asInteger = read

toString::Int->String
toString = show

reverseTuple::(a,b)->(b,a)
reverseTuple (a,b) = (b,a)

isVailed::String->Bool
isVailed "" = False
isVailed "0" = True
isVailed ('0':_) = False
isVailed _ = True

solve::[String]->Maybe Int
solve [] = Just 0
solve (x:xs) | isAlpha (x!!0) && x `elem` alc  = (+1) <$> solve xs
             | isDigit (x!!0) && (read x) < 19 = (+1) <$> solve xs
             | otherwise                       = solve xs

import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Maybe(fromJust)
readInt = fst . fromJust . LB.readInt

main = do
  s <- getContents
  print . map (s!!) $ [1, 4, 10]

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}

import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.ByteString as SB
import Data.ByteString.Internal (inlinePerformIO)
import Foreign.C.String (CString)
import Foreign.C (CDouble)
import Data.Maybe
import Data.List (mapAccumL, sort, maximumBy, minimum, foldl')
import Data.Array
import qualified Data.Map as M
import qualified Data.IntMap as IM
import Debug.Trace
import Data.Function (on)
import Data.Ord (comparing)
import System.Random(mkStdGen, random)
import Data.Int(Int64)
import Data.Sequence (iterateN)

foreign import ccall unsafe "stdlib.h atof" c_atof :: CString -> IO Double
unsafeReadDouble = inlinePerformIO . flip SB.useAsCString c_atof
{-# INLINE unsafeReadDouble #-}
readDouble = unsafeReadDouble . SB.concat . LB.toChunks
readInt = fst . fromJust . LB.readInt

debug :: Show a => a -> a
debug v = trace (show v) v
--debug _ = id

main = do (sn:desc) <- fmap LB.lines LB.getContents
          let n = readInt sn
              desc' = take n desc
              c1 = length . filter (`elem`
                    (map LB.pack ["ABSINTH", "BEER", "BRANDY", "CHAMPAGNE", "GIN", "RUM", "SAKE", "TEQUILA", "VODKA", "WHISKEY", "WINE"]))
                    $ desc'
              f s = case LB.readInt s of
                      Just (m, _)    -> m<18
                      otherwise -> False
              c2 = length . filter f $ desc'
          print (c1 + c2)

import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Maybe(fromJust)
import Data.Char(ord)
readInt = fst . fromJust . LB.readInt

main = do
  s <- LB.getContents
  print . map (LB.index s) $ [1, 4, 10]

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}

import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.ByteString as SB
import Data.ByteString.Internal (inlinePerformIO)
import Foreign.C.String (CString)
import Foreign.C (CDouble)
import Data.Maybe
import Data.List (mapAccumL, sort, maximumBy, minimum, foldl')
import Data.Array
import qualified Data.Map as M
import qualified Data.IntMap as IM
import Debug.Trace
import Data.Function (on)
import Data.Ord (comparing)
import System.Random(mkStdGen, random)
import Data.Int(Int64)
import Data.Sequence (iterateN)

foreign import ccall unsafe "stdlib.h atof" c_atof :: CString -> IO Double
unsafeReadDouble = inlinePerformIO . flip SB.useAsCString c_atof
{-# INLINE unsafeReadDouble #-}
readDouble = unsafeReadDouble . SB.concat . LB.toChunks
readInt = fst . fromJust . LB.readInt

debug :: Show a => a -> a
debug v = trace (show v) v
--debug _ = id

main = do (sn:desc) <- fmap LB.lines LB.getContents
          let n = readInt sn
              desc' = take n $ desc
              f s = case LB.readInt s of
                      Just (m, _)    -> m<18
                      otherwise      -> s `elem` (map LB.pack ["ABSINTH", "BEER", "BRANDY", "CHAMPAGNE", "GIN", "RUM", "SAKE", "TEQUILA", "VODKA", "WHISKEY", "WINE"])

              c = length . filter f . take n $ desc'
          print c

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}

import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.ByteString as SB
import Data.ByteString.Internal (inlinePerformIO)
import Foreign.C.String (CString)
import Foreign.C (CDouble)
import Data.Maybe
import Data.List (mapAccumL, sort, maximumBy, minimum, foldl')
import Data.Array
import qualified Data.Map as M
import qualified Data.IntMap as IM
import Debug.Trace
import Data.Function (on)
import Data.Ord (comparing)
import System.Random(mkStdGen, random)
import Data.Int(Int64)
import Data.Sequence (iterateN)

foreign import ccall unsafe "stdlib.h atof" c_atof :: CString -> IO Double
unsafeReadDouble = inlinePerformIO . flip SB.useAsCString c_atof
{-# INLINE unsafeReadDouble #-}
readDouble = unsafeReadDouble . SB.concat . LB.toChunks
readInt = fst . fromJust . LB.readInt

debug :: Show a => a -> a
debug v = trace (show v) v
--debug _ = id

main = do (sn:desc) <- fmap LB.lines LB.getContents
          let n = readInt sn
              f s = case LB.readInt s of
                      Just (m, _)    -> m<18
                      otherwise      -> s `elem` (map LB.pack ["ABSINTH", "BEER", "BRANDY", "CHAMPAGNE", "GIN", "RUM", "SAKE", "TEQUILA", "VODKA", "WHISKEY", "WINE"])

              c = length . filter f . take n $ desc
          print c


The new generation external memory contains an array of integers $$$a[1 \ldots n] = [a_1, a_2, \ldots, a_n]$$$.This type of memory does not support changing the value of an arbitrary element. Instead, it allows you to cut out any segment of the given array, cyclically shift (rotate) it by any offset and insert it back into the same place.Technically, each cyclic shift consists of two consecutive actions:   You may select arbitrary indices $$$l$$$ and $$$r$$$ ($$$1 \le l < r \le n$$$) as the boundaries of the segment.  Then you replace the segment $$$a[l \ldots r]$$$ with it's cyclic shift to the left by an arbitrary offset $$$d$$$. The concept of a cyclic shift can be also explained by following relations: the sequence $$$[1, 4, 1, 3]$$$ is a cyclic shift of the sequence $$$[3, 1, 4, 1]$$$ to the left by the offset $$$1$$$ and the sequence $$$[4, 1, 3, 1]$$$ is a cyclic shift of the sequence $$$[3, 1, 4, 1]$$$ to the left by the offset $$$2$$$. For example, if $$$a = [1, \color{blue}{3, 2, 8}, 5]$$$, then choosing $$$l = 2$$$, $$$r = 4$$$ and $$$d = 2$$$ yields a segment $$$a[2 \ldots 4] = [3, 2, 8]$$$. This segment is then shifted by the offset $$$d = 2$$$ to the left, and you get a segment $$$[8, 3, 2]$$$ which then takes the place of of the original elements of the segment. In the end you get $$$a = [1, \color{blue}{8, 3, 2}, 5]$$$.Sort the given array $$$a$$$ using no more than $$$n$$$ cyclic shifts of any of its segments. Note that you don't need to minimize the number of cyclic shifts. Any method that requires $$$n$$$ or less cyclic shifts will be accepted.

The first line contains an integer $$$t$$$ ($$$1 \leq t \leq 1000$$$) — the number of test cases. The next $$$2t$$$ lines contain the descriptions of the test cases.  The first line of each test case description contains an integer $$$n$$$ ($$$2 \leq n \leq 50$$$) — the length of the array. The second line consists of space-separated elements of the array $$$a_i$$$ ($$$-10^9 \leq a_i \leq 10^9$$$). Elements of array $$$a$$$ may repeat and don't have to be unique.

Print $$$t$$$ answers to all input test cases.  The first line of the answer of each test case should contain an integer $$$k$$$ ($$$0 \le k \le n$$$) — the number of actions to sort the array. The next $$$k$$$ lines should contain descriptions of the actions formatted as "$$$l$$$ $$$r$$$ $$$d$$$" (without quotes) where $$$l$$$ and $$$r$$$ ($$$1 \le l < r \le n$$$) are the boundaries of the segment being shifted, while $$$d$$$ ($$$1 \le d \le r - l$$$) is the offset value. Please remember that only the cyclic shifts to the left are considered so the chosen segment will be shifted by the offset $$$d$$$ to the to the left. Note that you are not required to find the minimum number of cyclic shifts needed for sorting. Any sorting method where the number of shifts does not exceed $$$n$$$ will be accepted. If the given array $$$a$$$ is already sorted, one of the possible answers is $$$k = 0$$$ and an empty sequence of cyclic shifts. If there are several possible answers, you may print any of them.

NoteExplanation of the fourth data set in the example:   The segment $$$a[2 \ldots 4]$$$ is selected and is shifted to the left by $$$2$$$: $$$[2, \color{blue}{5, 1, 4}, 3] \longrightarrow [2, \color{blue}{4, 5, 1}, 3]$$$  The segment $$$a[1 \ldots 5]$$$ is then selected and is shifted to the left by $$$3$$$: $$$[\color{blue}{2, 4, 5, 1, 3}] \longrightarrow [\color{blue}{1, 3, 2, 4, 5}]$$$  After that the segment $$$a[1 \ldots 2]$$$ is selected and is shifted to the left by $$$1$$$: $$$[\color{blue}{1, 3}, 2, 4, 5] \longrightarrow [\color{blue}{3, 1}, 2, 4, 5]$$$  And in the end the segment $$$a[1 \ldots 3]$$$ is selected and is shifted to the left by $$$1$$$: $$$[\color{blue}{3, 1, 2}, 4, 5] \longrightarrow [\color{blue}{1, 2, 3}, 4, 5]$$$

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

{-# language NoMonomorphismRestriction #-}

{-# options_ghc -Weverything                     #-}

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

-- (ghc -Werror -Wno-error=unsafe -O1 -no-keep-o-files -no-keep-hi-files -rtsopts -o a.out *.hs  &&  set -o pipefail  &&  cat -- input.txt | ./a.out > tmp.txt  &&  diff -sdu -- output.txt tmp.txt  &&  cat -- tmp.txt)

-- (echo 1000; for i in {1..1000}; do apg -a'1' -M'N' -m'9' -x'9' -n'50' | { echo 50; echo `cat`; };  done) > large_input.txt
--
-- (ghc -Werror -Wno-error=unsafe -O1 -no-keep-o-files -no-keep-hi-files -rtsopts -o a.out *.hs  &&  set -o pipefail  &&  cat -- large_input.txt | time ./a.out | wc --bytes)

import Prelude
-- import System.IO
import Control.Monad
import Data.List
import Data.Maybe

-- import Debug.Trace
-- trF showFunc x = trace msg x  where  msg = "\n" ++ "trF: " ++ showFunc x ++ "."
-- tr s x = trace msg x  where  msg = "\n" ++ "tr: " ++ s ++ ": " ++ show x ++ "."

main :: IO ()
main = do
    -- hSetBuffering stdout NoBuffering

    t <- readLn
    tcs <- replicateM t getTC

    (putStr . concatMap solve) tcs

getTC = do
    n <- readLn
    map read <$> wordsN n <$> getLine     :: IO [Int]

wordsN n s = ww  where  w = words s; ww | (length w == n) = w
                                        | otherwise = error "arr len"

unlinesN strs = (unlines . ([show $ length strs]++)) strs

solve xs = unlinesN . map showOp . filter ((/= 0) . snd) . zip [1..] $ minIndices
  where
    minIndices = map fst . take (length xs - 1) . tail . iterate step $ (undefined, xs)

    showOp (i, off) = show i ++ " " ++ show (i+off) ++ " " ++ show off

step (_, xs) = removeMin xs

removeMin [] = error "can not remove"
removeMin xs = (i, h ++ tail t)
  where
    i = (fromJust . findMinIndex) xs

    (h,t) = splitAt i xs

findMinIndex xs = let m = minimum xs
                  in  findIndex (== m) xs

import Control.Monad ( replicateM_, forM_ )
import Data.List ( intercalate )

calc n i a
  | n == i + 1 = [[]]
  | id == 0 = calc n (i + 1) na
  | otherwise = [i + 1, n, id] : calc n (i + 1) na
  where
      id = snd $ minimum $ zip a [0..]
      na = tail $ drop id a <> take id a

solve = do
    [n] <- map read.words <$> getLine :: IO [Int]
    a <- map read.words <$> getLine :: IO [Int]
    let f = init $ calc n 0 a
    print (length f)
    forM_ f $ \item -> do
      putStrLn $ unwords $ map show item

main = readLn >>= flip replicateM_ solve

import Control.Monad ( replicateM_, forM_ )
import Data.List ( intercalate, delete )

calc' :: [Int] -> Int -> [[Int]] -> [[Int]]
calc' [] _ acc = acc
calc' lst j acc =
  let (mn, i) = minimum $ zip lst [1..]
      lst' = delete mn lst
  in
    if i == 1 then calc' lst' (j + 1) acc
    else calc' lst' (j + 1) ([j + 1, j + i, i - 1] : acc)

calc :: [Int] -> [[Int]]
calc lst = reverse $ calc' lst 0 []

solve = do
    [n] <- map read.words <$> getLine :: IO [Int]
    a <- map read.words <$> getLine :: IO [Int]
    let f = calc a
    print (length f)
    forM_ f $ \item -> do
      putStrLn $ unwords $ map show item

main = readLn >>= flip replicateM_ solve

import Control.Monad ( replicateM_, forM_ )
import Data.List ( intercalate )

mix :: [Int] -> Int -> Int -> Int
mix (a : as) m i = if a == m then i else mix as m i + 1
mix [] _ _ = 0

shift :: [Int] -> Int -> [Int]
shift a s = drop s a <> take s a

calc :: Int -> Int -> [Int] -> [[Int]]
calc n i a
  | n == i + 1 = [[]]
  | id == 0 = calc n (i + 1) (tail $ shift a id)
  | otherwise = [i + 1, n, id] : calc n (i + 1) (tail $ shift a id)
  where
      id = mix a (minimum a) 0

solve = do
    [n] <- map read.words <$> getLine :: IO [Int]
    a <- map read.words <$> getLine :: IO [Int]
    let f = init $ calc n 0 a
    print (length f)
    forM_ f $ \item -> do
      putStrLn $ unwords $ map show item

main = readLn >>= flip replicateM_ solve

import Control.Monad
import Data.List

-- 2 5 1 -> 5 1 2 -> 1 2 5
-- 5 2 1 -> 2 1 5 -> 1 5 2

-- 2 5 1 4 3
-- 1 2 3 4 5
--
-- 1 2 3 4 5
-- 3 1 5 4 2

-- 5 2 1 4 3
-- 1 2 3 4 5
--
-- 1 2 3 4 5
-- 3 2 5 4 1

calc' :: [Int] -> Int -> [[Int]] -> [[Int]]
calc' [] j acc = acc
calc' lst j acc =
  let (mn,i) = minimum $ zip lst [1..]
      lst' = delete mn lst
  in
    if i == 1 then calc' lst' (j+1) acc
    else calc' lst' (j+1) ([j+1,j+i,i-1]:acc)

calc :: [Int] -> [[Int]]
calc lst = reverse $ calc' lst 0 []

main = do
  line <- getLine
  let t = read line :: Int
  forM_ [1..t] $ \_ -> do
    line <- getLine
    let n = read line :: Int
    line <- getLine
    let lst = map read $ words line :: [Int]
    let ans = calc lst
    putStrLn $ show $ length ans
    forM_ ans $ \item -> do
      putStrLn $ intercalate " " $ map show item

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

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

csort :: [Int] -> [Int]
csort [] = []
csort li = let
  tar = minimum li
  (pref, _tar : suff) = span (> tar) li
  in  length pref : csort (suff ++ pref)

mainFun :: SO
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    a <- getInts n
    let
      res = csort a
      ans = [[l, n, v] | (l, v) <- zip [1..n] res, v > 0]
    pure $ putInts [length ans] <> foldMap putInts ans

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

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

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

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

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

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

{-# language NoMonomorphismRestriction #-}

{-# options_ghc -Weverything                     #-}

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

-- (ghc -O1 -no-keep-o-files -no-keep-hi-files -rtsopts -o a.out *.hs  &&  set -o pipefail  &&  diff -sdu -- <(cat -- input.txt | ./a.out) output.txt)

import Prelude
import System.IO
import Control.Monad
import Data.List
import Data.Maybe

import Debug.Trace
-- trF showFunc x = trace msg x  where  msg = "\n" ++ "trF: " ++ showFunc x ++ "."
-- tr s x = trace msg x  where  msg = "\n" ++ "tr: " ++ s ++ ": " ++ show x ++ "."

main :: IO ()
main = do
    hSetBuffering stdout NoBuffering

    t <- readLn
    tcs <- replicateM t ((map read . words . head . tail) <$> replicateM 2 getLine) :: IO [[Int]]

    (hPutStr stderr . unlines . map show) tcs

    -- (hPutStr stderr . unlines . map (show . filter (not.isNoop) . solve 1)) tcs
    (hPutStr stderr . concatMap (showAns . filter (not.isNoop) . solve 1)) tcs

showAns xs = show (length xs) ++ "\n" ++ (unlines . map showOp) xs

solve _   [] = []
solve off xs = fix off op : solve (off+1) (tail $ shift xs op)
  where
    i = fromJust . findIndex (== minimum xs) $ xs

    op = (0, i, i)

fix n (l, r, d) = (l+n, r+n, d)

isNoop (_l, _r, d) = (d == 0)

showOp (l, r, d) = show l ++ " " ++ show r ++ " " ++ show d

shift xs (l,r,d) = beg ++ (shiftL mid d) ++ end
  where
    (beg, midEnd) = splitAt l       xs
    (mid, end   ) = splitAt (r-l+1) midEnd

shiftL xs 0 = xs
shiftL xs d = shiftL (tail xs ++ [head xs]) (d-1)

import Control.Monad ( replicateM_, forM_ )
import Data.List ( intercalate )

calc n i a
  | n == i + 1 = [[]]
  | id == 0 = calc n (i + 1) na
  | otherwise = [i + 1, n, id] : calc n (i + 1) na
  where
      id = snd $ minimum $ zip a [1..]
      na = tail $ drop id a <> take id a

solve = do
    [n] <- map read.words <$> getLine :: IO [Int]
    a <- map read.words <$> getLine :: IO [Int]
    let f = init $ calc n 0 a
    print (length f)
    forM_ f $ \item -> do
      putStrLn $ unwords $ map show item

main = readLn >>= flip replicateM_ solve

import Control.Monad
import Data.List

-- 2 5 1 -> 5 1 2 -> 1 2 5
-- 5 2 1 -> 2 1 5 -> 1 5 2

-- 2 5 1 4 3
-- 1 2 3 4 5
--
-- 1 2 3 4 5
-- 3 1 5 4 2

-- 5 2 1 4 3
-- 1 2 3 4 5
--
-- 1 2 3 4 5
-- 3 2 5 4 1

calc' :: [Int] -> Int -> [[Int]] -> [[Int]]
calc' [] j acc = acc
calc' lst j acc =
  let (mn,i) = minimum $ zip lst [1..]
      lst' = delete mn lst
  in
    if i == 1 then calc' lst' (j+1) acc
    else calc' lst' (j+1) ([j+1,j+i,j+i-1]:acc)

calc :: [Int] -> [[Int]]
calc lst = reverse $ calc' lst 0 []

main = do
  line <- getLine
  let t = read line :: Int
  forM_ [1..t] $ \_ -> do
    line <- getLine
    let n = read line :: Int
    line <- getLine
    let lst = map read $ words line :: [Int]
    let ans = calc lst
    putStrLn $ show $ length ans
    forM_ ans $ \item -> do
      putStrLn $ intercalate " " $ map show item


Gena loves sequences of numbers. Recently, he has discovered a new type of sequences which he called an almost arithmetical progression. A sequence is an almost arithmetical progression, if its elements can be represented as:  a1 = p, where p is some integer;  ai = ai - 1 + ( - 1)i + 1·q (i > 1), where q is some integer. Right now Gena has a piece of paper with sequence b, consisting of n integers. Help Gena, find there the longest subsequence of integers that is an almost arithmetical progression.Sequence s1,  s2,  ...,  sk is a subsequence of sequence b1,  b2,  ...,  bn, if there is such increasing sequence of indexes i1, i2, ..., ik (1  ≤  i1  <  i2  < ...   <  ik  ≤  n), that bij  =  sj. In other words, sequence s can be obtained from b by crossing out some elements.

The first line contains integer n (1 ≤ n ≤ 4000). The next line contains n integers b1, b2, ..., bn (1 ≤ bi ≤ 106).

Print a single integer — the length of the required longest subsequence.

NoteIn the first test the sequence actually is the suitable subsequence. In the second test the following subsequence fits: 10, 20, 10.

import Data.List
import Data.Tuple
import GHC.Exts
solve l = maximum $ (2 `min` length l) : (map length s) ++ [ f x y | x@(_:_:_) : t <- tails s, y<-t ]
  where
   s = reverse . sortWith length . groupWith fst $ zip l [0..]
   f x y = length . group $ map fst $ sortWith snd $  x ++ y

main = interact $ show . solve .tail . words

import Data.List
import GHC.Exts
solve l = maximum $ 2 `min` length l : map length s ++ [length . group $ map fst $ sortWith snd $  x ++ y  | x <- s, length x > 1, y<-s, y/=x ]
 where s = groupWith fst $ zip l [0..]

main = interact $ show . solve .tail . words

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

import Control.Monad
import Data.Array.Base
import Data.Array.IO (IOUArray)
import qualified Data.ByteString.Char8 as B
import Data.IORef
import Data.Maybe (fromJust)

rep :: Int -> Int -> (Int -> IO ()) -> IO ()
rep !m !n f=go m where go !i=when(i<n)$f i>>go(i+1)

main :: IO ()
main = do
  n <- readLn
  bs <- fmap(map(fst.fromJust.B.readInt).B.words)B.getLine
  dp <- newArray (0,n*n-1) 0 :: IO (IOUArray Int Int)
  v2i <- newArray (0,1000000) (-1) :: IO (IOUArray Int Int)

  forM_ (zip[0..]bs) $ \(i,b)-> do
    i0 <- unsafeRead v2i b
    when (i0 < 0) $ unsafeWrite v2i b i

  xs <- mapM (unsafeRead v2i) bs

  let get (i,j) = unsafeRead dp (i*n+j)
      put (i,j) v = unsafeWrite dp (i*n+j) v

  forM_ (zip[0..]xs) $ \(i,x) -> do
      if i==x
         then do
           put (i,i) 1
           rep 0 i $ \j -> do
             put (j,x) 2
         else do
           rep 0 i $ \j -> do
             xj <- get (x,j)
             jx <- get (j,x)
             put (j,x) $ max jx (xj+1)

  ans <- newIORef 0 :: IO (IORef Int)

  rep 0 (n*n) $ \ij-> do
    dpij <- unsafeRead dp ij
    x <- readIORef ans
    writeIORef ans $! max dpij x

  readIORef ans >>= print

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

import Control.Monad
import Data.Array.Base
import Data.Array.IO (IOUArray)
import qualified Data.ByteString.Char8 as B
import Data.IORef
import Data.Maybe (fromJust)

rep :: Int -> Int -> (Int -> IO ()) -> IO ()
rep !m !n f=go m where go !i=when(i<n)$f i>>go(i+1)

main :: IO ()
main = do
  n <- readLn
  bs <- fmap(map(fst.fromJust.B.readInt).B.words)B.getLine
  dp <- newArray (0,n*n-1) 0 :: IO (IOUArray Int Int)
  v2i <- newArray (0,1000000) (-1) :: IO (IOUArray Int Int)
  i2v <- newListArray (0,n-1) bs :: IO (IOUArray Int Int)

  forM_ (zip[0..]bs) $ \(i,b)-> do
    i0 <- unsafeRead v2i b
    when (i0 < 0) $ unsafeWrite v2i b i

  forM_ (zip[0..]bs) $ \(i,b)-> do
    i0 <- unsafeRead v2i b
    if i0<i
       then do
         rep 0 i $ \j-> do
           vj <- unsafeRead i2v j
           j0 <- unsafeRead v2i vj
           when (j0==j) $ do
             dpij <- unsafeRead dp $ n*i0+j
             unsafeWrite dp (n*j+i0) $ dpij+1
       else do
         unsafeWrite dp (i*n+i) 1
         rep 0 i $ \j-> do
           unsafeWrite dp (j*n+i) 2

  ans <- newIORef 0 :: IO (IORef Int)

  rep 0 (n*n) $ \ij-> do
    dpij <- unsafeRead dp ij
    x <- readIORef ans
    writeIORef ans $! max dpij x

  readIORef ans >>= print

{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import Control.Monad
import Data.Array.Base
import Data.Array.IO (IOUArray)
import qualified Data.ByteString.Char8 as B
import Data.IORef
import Data.Maybe

main :: IO ()
main = do
  n <- readLn :: IO Int
  bs <- fmap(map(fst.fromJust.B.readInt).B.words)B.getLine
  dp <- newArray (0,4000*4000-1) 0 :: IO (IOUArray Int Int)
  v2i <- newArray (0,1000000) (-1) :: IO (IOUArray Int Int)

  forM_ (zip[0..]bs) $ \ (i,b)-> do
    visited <- unsafeRead v2i b
    when (visited < 0) $ do
      unsafeWrite v2i b i
      unsafeWrite dp (i*4000+i) 1

  forM_ bs $ \b-> do
    i <- unsafeRead v2i b
    forM_ [0..3999] $ \j-> do
      dpij <- unsafeRead dp $ 4000*i+j
      unsafeWrite dp (4000*i+j) $ dpij+1

  ans <- newIORef 0 :: IO (IORef Int)

  forM_ [0..4000*4000-1] $ \i-> do
    ai <- unsafeRead dp i
    x <- readIORef ans
    writeIORef ans $! max ai x

  readIORef ans >>= print

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

import Control.Monad
import Data.Array.Base
import Data.Array.IO (IOUArray)
import qualified Data.ByteString.Char8 as B
import Data.IORef
import Data.Maybe (fromJust)

rep :: Int -> Int -> (Int -> IO ()) -> IO ()
rep !m !n f=go m where go !i=when(i<n)$f i>>go(i+1)

main :: IO ()
main = do
  _ <- getLine
  bs <- fmap(map(fst.fromJust.B.readInt).B.words)B.getLine
  dp <- newArray (0,4000*4000-1) 0 :: IO (IOUArray Int Int)
  v2i <- newArray (0,1000000) (-1) :: IO (IOUArray Int Int)

  forM_ (zip[0..]bs) $ \(i,b)-> do
    visited <- unsafeRead v2i b
    when (visited < 0) $ unsafeWrite v2i b i

  forM_ (zip[0..]bs) $ \(i,b)-> do
    i0 <- unsafeRead v2i b
    if i0<i
       then do
         rep 0 i $ \j-> do
           dpij <- unsafeRead dp $ 4000*i0+j
           unsafeWrite dp (4000*j+i0) $ dpij+1
       else do
         unsafeWrite dp (i*4000+i) 1
         rep 0 i $ \j-> do
           unsafeWrite dp (j*4000+i) 2

  ans <- newIORef 0 :: IO (IORef Int)

  rep 0 (4000*4000) $ \i-> do
    ai <- unsafeRead dp i
    x <- readIORef ans
    writeIORef ans $! max ai x

  readIORef ans >>= print

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

import Control.Applicative
import Control.Monad
import Data.Array.Base
import Data.Array.IO (IOUArray)
import qualified Data.ByteString.Char8 as B
import Data.IORef
import Data.Maybe (fromJust)

rep :: Int -> Int -> (Int -> IO ()) -> IO ()
rep !m !n f = go m
   where
     go !i
       | i<n = f i >> go (i+1)
       | otherwise = return ()

main :: IO ()
main = do
  _ <- getLine
  bs <- fmap(map(fst.fromJust.B.readInt).B.words)B.getLine
  dp <- newArray (0,4000*4000-1) 0 :: IO (IOUArray Int Int)
  v2i <- newArray (0,1000000) (-1) :: IO (IOUArray Int Int)

  forM_ (zip[0..]bs) $ \ (i,b)-> do
    visited <- unsafeRead v2i b
    if visited < 0
       then unsafeWrite v2i b i
       else unsafeWrite dp (i*4000+i) 1

  forM_ bs $ \b-> do
    i <- unsafeRead v2i b
    let !k = 4000*i
    rep 0 4000 $ \j-> do
      dpij <- unsafeRead dp $ k+j
      unsafeWrite dp (k+j) $ max 2 $ dpij+1

  ans <- newIORef 0 :: IO (IORef Int)

  rep 0 (4000*4000) $ \i-> do
    ai <- unsafeRead dp i
    x <- readIORef ans
    writeIORef ans $! max ai x

  readIORef ans >>= print


One popular website developed an unusual username editing procedure. One can change the username only by deleting some characters from it: to change the current name s, a user can pick number p and character c and delete the p-th occurrence of character c from the name. After the user changed his name, he can't undo the change.For example, one can change name "arca" by removing the second occurrence of character "a" to get "arc". Polycarpus learned that some user initially registered under nickname t, where t is a concatenation of k copies of string s. Also, Polycarpus knows the sequence of this user's name changes. Help Polycarpus figure out the user's final name.

The first line contains an integer k (1 ≤ k ≤ 2000). The second line contains a non-empty string s, consisting of lowercase Latin letters, at most 100 characters long. The third line contains an integer n (0 ≤ n ≤ 20000) — the number of username changes. Each of the next n lines contains the actual changes, one per line. The changes are written as "pi ci" (without the quotes), where pi (1 ≤ pi ≤ 200000) is the number of occurrences of letter ci, ci is a lowercase Latin letter. It is guaranteed that the operations are correct, that is, the letter to be deleted always exists, and after all operations not all letters are deleted from the name. The letters' occurrences are numbered starting from 1.

Print a single string — the user's final name after all changes are applied to it.

NoteLet's consider the first sample. Initially we have name "bacbac"; the first operation transforms it into "bacbc", the second one — to "acbc", and finally, the third one transforms it into "acb".

import Control.Monad (liftM, filterM, forM_, replicateM)
import Control.Monad.ST (ST)

import Data.Array.MArray (newArray, readArray, writeArray)
import Data.Array.ST (STUArray, runSTUArray)
import Data.Array.Unboxed (UArray, assocs)

import Data.Char (ord)
import Data.List (intercalate, sortBy)

solve :: Int -> String -> [(Int, Char)] -> String
solve k s qs  =  map fst $ sortBy compSnd $ filter ((> 0) . snd)
    $ map (\((c, _), i) -> (c, i)) $ assocs array
  where
    compSnd (a, b) (c, d)  =  compare b d
    max  =  sqrtMax^2
    sqrtMax  =  450
    fullS  =  take (k * length s) $ cycle s
    array :: UArray (Char, Int) Int
    array  =  runSTUArray $ do
        array  <-  newArray (('a', 1), ('z', max)) 0
        chars  <-  newArray ('a', 'z') 1 :: ST s (STUArray s Char Int)
        forM_ (zip [1..] fullS)
          (
            \(i, c) -> do
              j  <-  readArray chars c
              writeArray array (c, j) i
              writeArray chars c (j + 1)
          )
        d  <-  newArray (('a', 0), ('z', sqrtMax)) 0 :: ST s (STUArray s (Char, Int) Int)
        forM_ [(c, i) | c <- ['a'..'z'], i <- [0..sqrtMax]]
          (
            \(c, i) -> writeArray d (c, i) (sqrtMax * i)
          )
        forM_ qs
          (
            \(m, c) -> do
              j  <-  liftM head $ filterM
                         (\j -> readArray d (c, j) >>= return . (>= m))
                         [1..sqrtMax]

              k  <-  do
                         m'  <-  readArray d (c, j-1)
                         findK c (m-m'-1) ((j-1) * sqrtMax + 1) array

              writeArray array (c, k) 0

              forM_ [j .. sqrtMax]
                (
                  \j -> do
                    dj  <-  readArray d (c, j)
                    writeArray d (c, j) (dj-1)
                )

          )

        return array
          where
            findK :: Char -> Int -> Int -> STUArray s (Char, Int) Int -> ST s Int
            findK c m k array  =  do
                a  <-  readArray array (c, k)
                if m == 0 && a > 0
                    then return k
                    else findK c (if a == 0 then m else (m-1)) (k+1) array

main :: IO ()
main  =  do
    k  <-  readLn
    s  <-  getLine
    n  <-  readLn
    qs  <-  replicateM n readQuery
    putStrLn $ solve k s qs

  where

    readQuery :: IO (Int, Char)
    readQuery  =  do
        [a, b]  <-  liftM words getLine
        return (read a, head b)

import Control.Monad (liftM, replicateM)
import Data.Char (ord)
import Data.List (intercalate)
import Data.Map ((!), adjust, delete, empty, fromList, fromListWith, member)

solve :: Int -> String -> [(Int, Char)] -> String
solve k s qs  =  solve' mapQ mapC $ take (k * length s) $ cycle s
  where
    mapC  =  fromList [(c, 1) | c <- ['a'..'z']]
    mapQ  =  fromListWith (+) [(q, 1) | q <- qs]
    solve' _ _ ""  =  ""
    solve' mapQ mapC (c:s)
      | member keyQ mapQ  =  solve' mapQ' mapC s
      | otherwise  =  c : solve' mapQ mapC' s
      where
        keyQ   =  (mapC ! c, c)
        mapC'  =  adjust (+1) c mapC
        mapQ'  =  if mapQ ! keyQ == 1 then
                      delete keyQ mapQ
                  else
                      adjust (\x -> x - 1) keyQ mapQ

main :: IO ()
main  =  do
    k  <-  readLn
    s  <-  getLine
    n  <-  readLn
    qs  <-  replicateM n readQuery
    putStrLn $ solve k s qs

  where

    readQuery :: IO (Int, Char)
    readQuery  =  do
        [a, b]  <-  liftM words getLine
        return (read a, head b)

    prints :: Show a => [a] -> IO ()
    prints  =  putStrLn . intercalate " " . map show

    readPair :: Num a => IO (a, a)
    readPair  =  do
        [a, b]  <-  reads
        return (a, b)

    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' a' s
          where
            a'  =  10 * a + fromIntegral (ord c - ord '0')

import Control.Monad (liftM, filterM, forM_, replicateM)
import Control.Monad.ST (ST)

import Data.Array.MArray (newArray, readArray, writeArray)
import Data.Array.ST (STUArray, runSTUArray)
import Data.Array.Unboxed (UArray, assocs)

import Data.Char (ord)
import Data.List (intercalate, sortBy)

solve :: Int -> String -> [(Int, Char)] -> String
solve k s qs  =  map fst $ sortBy compSnd $ filter ((> 0) . snd)
    $ map (\((c, _), i) -> (c, i)) $ assocs array
  where
    compSnd (a, b) (c, d)  =  compare b d
    max  =  20000
    sqrtMax  =  150
    fullS  =  take (k * length s) $ cycle s
    array :: UArray (Char, Int) Int
    array  =  runSTUArray $ do
        array  <-  newArray (('a', 1), ('z', max)) 0
        chars  <-  newArray ('a', 'z') 1 :: ST s (STUArray s Char Int)
        forM_ (zip [1..] fullS)
          (
            \(i, c) -> do
              j  <-  readArray chars c
              writeArray array (c, j) i
              writeArray chars c (j + 1)
          )
        d  <-  newArray (('a', 0), ('z', sqrtMax)) 0 :: ST s (STUArray s (Char, Int) Int)
        forM_ [(c, i) | c <- ['a'..'z'], i <- [0..sqrtMax]]
          (
            \(c, i) -> writeArray d (c, i) (sqrtMax * i)
          )
        forM_ qs
          (
            \(m, c) -> do
              j  <-  liftM head $ filterM
                         (\j -> readArray d (c, j) >>= return . (>= m))
                         [1..sqrtMax]

              k  <-  do
                         m'  <-  readArray d (c, j-1)
                         liftM (head . drop (m-m'-1)) $ filterM
                             (\l -> readArray array (c, m' + l) >>= return . (> 0))
                             [1..sqrtMax]

              writeArray array (c, k) 0

              forM_ [j .. sqrtMax]
                (
                  \j -> do
                    dj  <-  readArray d (c, j)
                    writeArray d (c, j) (dj-1)
                )

          )
        return array

main :: IO ()
main  =  do
    k  <-  readLn
    s  <-  getLine
    n  <-  readLn
    qs  <-  replicateM n readQuery
    putStrLn $ solve k s qs

  where

    readQuery :: IO (Int, Char)
    readQuery  =  do
        [a, b]  <-  liftM words getLine
        return (read a, head b)

    prints :: Show a => [a] -> IO ()
    prints  =  putStrLn . intercalate " " . map show

    readPair :: Num a => IO (a, a)
    readPair  =  do
        [a, b]  <-  reads
        return (a, b)

    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' a' s
          where
            a'  =  10 * a + fromIntegral (ord c - ord '0')

import Control.Monad (liftM, filterM, forM_, replicateM)
import Control.Monad.ST (ST)

import Data.Array.MArray (newArray, readArray, writeArray)
import Data.Array.ST (STUArray, runSTUArray)
import Data.Array.Unboxed (UArray, assocs)

import Data.Char (ord)
import Data.List (intercalate, sortBy)

solve :: Int -> String -> [(Int, Char)] -> String
solve k s qs  =  map fst $ sortBy compSnd $ filter ((> 0) . snd)
    $ map (\((c, _), i) -> (c, i)) $ assocs array
  where
    compSnd (a, b) (c, d)  =  compare b d
    max  =  sqrtMax^2
    sqrtMax  =  450
    fullS  =  take (k * length s) $ cycle s
    array :: UArray (Char, Int) Int
    array  =  runSTUArray $ do
        array  <-  newArray (('a', 1), ('z', max)) 0
        chars  <-  newArray ('a', 'z') 1 :: ST s (STUArray s Char Int)
        forM_ (zip [1..] fullS)
          (
            \(i, c) -> do
              j  <-  readArray chars c
              writeArray array (c, j) i
              writeArray chars c (j + 1)
          )
        d  <-  newArray (('a', 0), ('z', sqrtMax)) 0 :: ST s (STUArray s (Char, Int) Int)
        forM_ [(c, i) | c <- ['a'..'z'], i <- [0..sqrtMax]]
          (
            \(c, i) -> writeArray d (c, i) (sqrtMax * i)
          )
        forM_ qs
          (
            \(m, c) -> do
              j  <-  liftM head $ filterM
                         (\j -> readArray d (c, j) >>= return . (>= m))
                         [1..sqrtMax]

              k  <-  do
                         m'  <-  readArray d (c, j-1)
                         findK c (m'+1) m ((j-1) * sqrtMax + 1) array

              writeArray array (c, k) 0

              forM_ [j .. sqrtMax]
                (
                  \j -> do
                    dj  <-  readArray d (c, j)
                    writeArray d (c, j) (dj-1)
                )

          )

        return array
          where
            findK :: Char -> Int -> Int -> Int -> STUArray s (Char, Int) Int -> ST s Int
            findK c m' m k array  =  if m' == m
                then return k
                else do
                    a  <-  readArray array (c, k)
                    findK c (if a == 0 then m' else m' + 1) m (k+1) array

main :: IO ()
main  =  do
    k  <-  readLn
    s  <-  getLine
    n  <-  readLn
    qs  <-  replicateM n readQuery
    putStrLn $ solve k s qs

  where

    readQuery :: IO (Int, Char)
    readQuery  =  do
        [a, b]  <-  liftM words getLine
        return (read a, head b)

import Control.Monad (liftM, filterM, forM_, replicateM)
import Control.Monad.ST (ST)

import Data.Array.MArray (newArray, readArray, writeArray)
import Data.Array.ST (STUArray, runSTUArray)
import Data.Array.Unboxed (UArray, assocs)

import Data.Char (ord)
import Data.List (intercalate, sortBy)

solve :: Int -> String -> [(Int, Char)] -> String
solve k s qs  =  map fst $ sortBy compSnd $ filter ((> 0) . snd)
    $ map (\((c, _), i) -> (c, i)) $ assocs array
  where
    compSnd (a, b) (c, d)  =  compare b d
    max  =  sqrtMax^2
    sqrtMax  =  450
    fullS  =  take (k * length s) $ cycle s
    array :: UArray (Char, Int) Int
    array  =  runSTUArray $ do
        array  <-  newArray (('a', 1), ('z', max)) 0
        chars  <-  newArray ('a', 'z') 1 :: ST s (STUArray s Char Int)
        forM_ (zip [1..] fullS)
          (
            \(i, c) -> do
              j  <-  readArray chars c
              writeArray array (c, j) i
              writeArray chars c (j + 1)
          )
        d  <-  newArray (('a', 0), ('z', sqrtMax)) 0 :: ST s (STUArray s (Char, Int) Int)
        forM_ [(c, i) | c <- ['a'..'z'], i <- [0..sqrtMax]]
          (
            \(c, i) -> writeArray d (c, i) (sqrtMax * i)
          )
        forM_ qs
          (
            \(m, c) -> do
              j  <-  liftM head $ filterM
                         (\j -> readArray d (c, j) >>= return . (>= m))
                         [1..sqrtMax]

              k  <-  do
                         m'  <-  readArray d (c, j-1)
                         findK c m' m ((j-1) * sqrtMax + 1) array

              writeArray array (c, k) 0

              forM_ [j .. sqrtMax]
                (
                  \j -> do
                    dj  <-  readArray d (c, j)
                    writeArray d (c, j) (dj-1)
                )

          )

        return array
          where
            findK :: Char -> Int -> Int -> Int -> STUArray s (Char, Int) Int -> ST s Int
            findK c m' m k array  =  if m' == m
                then return k
                else do
                    a  <-  readArray array (c, k)
                    findK c (if a == 0 then m' else m' + 1) m (k+1) array

main :: IO ()
main  =  do
    k  <-  readLn
    s  <-  getLine
    n  <-  readLn
    qs  <-  replicateM n readQuery
    putStrLn $ solve k s qs

  where

    readQuery :: IO (Int, Char)
    readQuery  =  do
        [a, b]  <-  liftM words getLine
        return (read a, head b)


...Once upon a time a man came to the sea. The sea was stormy and dark. The man started to call for the little mermaid to appear but alas, he only woke up Cthulhu...Whereas on the other end of the world Pentagon is actively collecting information trying to predict the monster's behavior and preparing the secret super weapon. Due to high seismic activity and poor weather conditions the satellites haven't yet been able to make clear shots of the monster. The analysis of the first shot resulted in an undirected graph with n vertices and m edges. Now the world's best minds are about to determine whether this graph can be regarded as Cthulhu or not.To add simplicity, let's suppose that Cthulhu looks from the space like some spherical body with tentacles attached to it. Formally, we shall regard as Cthulhu such an undirected graph that can be represented as a set of three or more rooted trees, whose roots are connected by a simple cycle.It is guaranteed that the graph contains no multiple edges and self-loops.

The first line contains two integers — the number of vertices n and the number of edges m of the graph (1 ≤ n ≤ 100, 0 ≤ m ≤ ). Each of the following m lines contains a pair of integers x and y, that show that an edge exists between vertices x and y (1 ≤ x, y ≤ n, x ≠ y). For each pair of vertices there will be at most one edge between them, no edge connects a vertex to itself.

Print "NO", if the graph is not Cthulhu and "FHTAGN!" if it is.

NoteLet us denote as a simple cycle a set of v vertices that can be numbered so that the edges will only exist between vertices number 1 and 2, 2 and 3, ..., v - 1 and v, v and 1.A tree is a connected undirected graph consisting of n vertices and n - 1 edges (n > 0).A rooted tree is a tree where one vertex is selected to be the root.

module Main where

import Control.Monad
import Data.Array.IO
import Data.Array.MArray
import Data.Ix

newDisSet :: (MArray a i m, Ix i) => (i, i) -> m (a i i)
newDisSet b = newListArray b (range b)

rootDisSet :: (MArray a i m, Ix i) => (a i i) -> i -> m i
rootDisSet s i = do
    p <- readArray s i
    if p == i
        then return p
        else do
            p' <- rootDisSet s p
            when ( p' /= p ) $ writeArray s i p'
            return p'

unionDisSet :: (MArray a i m, Ix i) => (a i i) -> i -> i -> m ()
unionDisSet s i j = do
    pi <- rootDisSet s i
    pj <- rootDisSet s j
    when ( pi /= pj ) $ writeArray s pj pi

testDisSet :: (MArray a i m, Ix i) => (a i i) -> i -> i -> m Bool
testDisSet s i j = do
    pi <- rootDisSet s i
    pj <- rootDisSet s j
    return $ pi == pj

main = do
    [n, m] <- ( map read . words ) `liftM` getLine :: IO [Int]

    res <- if n == m
        then do
            disSet <- newDisSet (1, n) :: IO (IOArray Int Int)
            replicateM m $ do
                [i, j] <- ( map read . words ) `liftM` getLine
                unionDisSet disSet i j
            foldM (\ans i -> ( ans && ) `liftM` testDisSet disSet 1 i) True [2..n]
        else return False
    putStrLn $ if res
        then "FHTAGN!"
        else "NO"

import Data.Graph
main = do
  [n, m]:es <- fmap (map (map read.words).lines) getContents
  let g = buildG (1,n) $ concat [[(x,y),(y,x)] | [x,y] <- es]
  let c = length (components g)
  putStrLn $ if n == m && c == 1 then "FHTAGN!" else "NO"

import Data.Graph

findCthulhu :: (Int, Int, [(Int, Int)]) -> String
findCthulhu (vn, en, edges) =
	if vn == en && (length $ components $ buildG (1, vn) edges) == 1
	then "FHTAGN!"
	else "NO"

parseInput :: String -> (Int, Int, [(Int, Int)])
parseInput input = (vn, ve, edges) where
	vn = read $ head $ words $ input
	ve = read $ head $ tail $ words $ input
	edges = pairsFromStrings $ tail $ tail $ words $ input where
		pairsFromStrings [] = []
		pairsFromStrings (f:s:xs) = (read f, read s) : pairsFromStrings xs

main = do
	input <- getContents
	putStr $ findCthulhu $ parseInput input -- "6 5 5 6 4 6 3 1 5 1 1 2"

-- восстановить дерево по входным данным
-- сравнить число ребер с числом вершин и проверить связность (дфс)
--6 6
--6 3
--6 4
--5 1
--2 5
--1 4
--5 4

import Data.Graph

--main = do
--	vn <- read
--	en <- read

--	edges <- map toInteger (words getContents)
--	print $ length $ components $ buildG edges

findCthulhu :: (Int, Int, [(Int, Int)]) -> String
findCthulhu (vn, en, edges) =
	if vn == en && (length $ components $ buildG (1, vn) edges) == 1
	then "FHTAGN!"
	else "NO"

parseInput :: String -> (Int, Int, [(Int, Int)])
parseInput input = (vn, ve, edges) where
	vn = read $ head $ words $ input
	ve = read $ head $ tail $ words $ input
	edges = pairsFromStrings $ tail $ tail $ words $ input where
		pairsFromStrings [] = []
		pairsFromStrings (f:s:xs) = (read f, read s) : pairsFromStrings xs

--parseInput :: String -> (Int, Int, [(Int, Int)])
--parseInput input = (fst $ head pairs, snd $ head pairs, (tail pairs)) where
--	pairs = pairsFromStrings $ words input
--	pairsFromStrings [] = []
--	pairsFromStrings (f:s:xs) = (read f, read s) : pairsFromStrings xs

--pairsFromStrings :: [String] -> [(Int, Int)]
--pairsFromStrings (f:s:xs) = (read f, read s) : (pairsFromStrings xs)

main = do
	input <- getContents
	putStr $ findCthulhu $ parseInput input --"6 5 5 6 4 6 3 1 5 1 1 2" --" 6 6 3 6 4 5 1 2 5 1 4 5 4"
	--let pairs = pairsFromStrings $ words text
	--in print $ findCthulhu (fst $ head pairs) (snd $ head pairs) (tail pairs)

	--(1, 6) [(6, 3), (6, 4), (5, 1), (2, 5), (1, 4), (5, 4)]

		--[('*', 6, [3, 4]),
		-- ('*', 3, [6]),
		-- ('*', 4, [6, 1, 5]),
		-- ('*', 5, [1, 2, 4]),
		-- ('*', 1, [5, 4]),
		-- ('*', 2, [5])]

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
{-# OPTIONS_GHC -O2 #-}

import Data.List
import Data.Maybe
import Data.Char
import Data.Array.IArray
import Data.Array.Unboxed (UArray)
import Data.Int
import Data.Ratio
import Data.Bits
import Data.Function
import Data.Ord
--import Control.Monad.State
import Control.Monad
import Control.Applicative
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Sequence (Seq, (<|), (|>), (><), ViewL(..), ViewR(..))
import qualified Data.Sequence as Seq
import qualified Data.Foldable as F
import Data.Graph

parseInput = do
    n <- readInt
    m <- readInt
    edges <- replicateM m ((,) <$> readInt <*> readInt)
    return (n, edges)
  where
    readInt = state $ fromJust . BS.readInt . BS.dropWhile isSpace
    readInteger = state $ fromJust . BS.readInteger . BS.dropWhile isSpace
    readString = state $ BS.span (not . isSpace) . BS.dropWhile isSpace
    readLine = state $ BS.span (not . isEoln) . BS.dropWhile isEoln
    isEoln ch = ch == '\r' || ch == '\n'

main = putStrLn =<< solve . evalState parseInput <$> BS.getContents

solve :: (Int, [(Int,Int)]) -> String
solve (n, edges)
    | n == m && comps == 1 = "FHTAGN!"
    | otherwise            = "NO"
  where
    m = length edges

    graph = buildG (1, n) $ concat [[(x, y), (y, x)] | (x, y) <- edges]

    comps = length $ components graph

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

class (Monad m) => MonadState s m | m -> s where
	get :: m s
	put :: s -> m ()

modify :: (MonadState s m) => (s -> s) -> m ()
modify f = do
	s <- get
	put (f s)

gets :: (MonadState s m) => (s -> a) -> m a
gets f = do
	s <- get
	return (f s)

newtype State s a = State { runState :: s -> (a, s) }

instance Functor (State s) where
	fmap f m = State $ \s -> let
		(a, s') = runState m s
		in (f a, s')

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

instance Monad (State s) where
	return a = State $ \s -> (a, s)
	m >>= k  = State $ \s -> let
		(a, s') = runState m s
		in runState (k a) s'

instance MonadState s (State s) where
	get   = State $ \s -> (s, s)
	put s = State $ \_ -> ((), s)

evalState :: State s a -> s -> a
evalState m s = fst (runState m s)

execState :: State s a -> s -> s
execState m s = snd (runState m s)

mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
mapState f m = State $ f . runState m

withState :: (s -> s) -> State s a -> State s a
withState f m = State $ runState m . f

state = State

import Data.List
import Data.String

addEdge' :: Int -> Int -> [[Int]] -> [[Int]]
addEdge' 0 b (g:gs) = ((b:g):gs)
addEdge' a b (g:gs) = g:addEdge' (a-1) b gs

addEdge :: Int -> Int -> [[Int]] -> [[Int]]
addEdge a b g = addEdge' a b $ addEdge' b a g

reachable' :: [Int] -> [[Int]] -> [Int] -> [Int]
reachable' [] g visited = []
reachable' (v:vs) g visited  =  fromv ++ reachable' vs g (fromv ++ visited)
								where fromv  =  if elem v visited
												then []
												else v:reachable' (g!!v) g (v:visited);

reachable :: Int -> [[Int]] -> [Int]
reachable v g = reachable' [v] g []

isConnected :: [[Int]] -> Bool
isConnected g = length g == (length $ reachable 0 g)

isKtulhu :: [[Int]] -> Bool
isKtulhu g = isConnected g && 2 * (length g) == length (concat g)

parse :: String -> [Int]
parse s = [read $ w !! 0, read $ w !! 1] where w = words s

parseGraph' :: [[Int]] -> [String] -> [[Int]]
parseGraph' g []     = g
parseGraph' g (s:sx) = parseGraph' (addEdge (e !! 0 - 1) (e !! 1 - 1) g) sx where e = parse s

parseGraph :: String -> [[Int]]
parseGraph s = parseGraph' (replicate ((parse $ head w) !! 0) []) (tail w) where w = lines s

ktulhuState :: Bool -> String
ktulhuState ktulhu = if ktulhu then "FHTAGN!" else "NO"

main = do
		graphData <- getContents
		putStrLn $ ktulhuState $ isKtulhu $ parseGraph $ graphData

import Data.List
import Data.String

{-
dropEdge' :: Int -> Int -> [[Int]] -> [[Int]]
dropEdge' 0 b (g:gs) = (delete b g):gs
dropEdge' a b (g:gs) = g:dropEdge' (a-1) b gs

dropEdge :: Int -> Int -> [[Int]] -> [[Int]]
dropEdge a b g = dropEdge' a b $ dropEdge' b a g

getCycle'' :: [Int] -> [[Int]] -> [Int] -> [Int]
getCycle'' [] g stack = []
getCycle'' (v:vs) g stack = if aCycle == []
							then getCycle'' vs g stack
							else aCycle
							where aCycle = getCycle' v g stack

getCycle' :: Int -> [[Int]] -> [Int] -> [Int]
getCycle' v g [] 			= 	getCycle'' (g!!v) g [v]
getCycle' v g stack@(s:sx)  =   if elem v sx
					    	   	then v:takeWhile (\x -> not $ x == v) stack
					    	   	else getCycle'' (delete s $ g!!v) g (v:stack)

getCycle :: [[Int]] -> [Int]
getCycle g = getCycle' 0 g []

hasSingleCycle :: [[Int]] -> Bool
hasSingleCycle g =  if aCycle == []
				    then False
					else [] == getCycle (dropEdge (aCycle !! 0) (aCycle !! 1) g)
				    where aCycle = getCycle g-}

addEdge' :: Int -> Int -> [[Int]] -> [[Int]]
addEdge' 0 b (g:gs) = ((b:g):gs)
addEdge' a b (g:gs) = g:addEdge' (a-1) b gs

addEdge :: Int -> Int -> [[Int]] -> [[Int]]
addEdge a b g = addEdge' a b $ addEdge' b a g

reachable' :: [Int] -> [[Int]] -> [Int] -> [Int]
reachable' [] g visited = []
reachable' (v:vs) g visited  =  if elem v visited
							  	then reachable' vs g visited
								else fromv ++ reachable' vs g (fromv ++ visited)
								where fromv = v:reachable' (g!!v) g (v:visited);

reachable :: Int -> [[Int]] -> [Int]
reachable v g = reachable' [v] g []

isConnected :: [[Int]] -> Bool
isConnected g = length g == (length $ reachable 0 g)

isKtulhu :: [[Int]] -> Bool
isKtulhu g = isConnected g && 2 * (length g) == length (concat g)

parse :: String -> [Int]
parse s = [read $ w !! 0, read $ w !! 1] where w = words s

parseGraph' :: [[Int]] -> [String] -> [[Int]]
parseGraph' g []     = g
parseGraph' g (s:sx) = parseGraph' (addEdge (e !! 0 - 1) (e !! 1 - 1) g) sx where e = parse s

parseGraph :: String -> [[Int]]
parseGraph s = parseGraph' (replicate ((parse $ head w) !! 0) []) (tail w) where w = lines s

ktulhuState :: Bool -> String
ktulhuState ktulhu = if ktulhu then "FHTAGN!" else "NO"

main = do
		graphData <- getContents
		putStrLn $ ktulhuState $ isKtulhu $ parseGraph $ graphData

import Data.Graph

solve ((n, _):es) =
  if (length $ components graph) == 1 && n == (length es) then
    "FHTAGN!"
  else
    "NO"
  where graph = buildG (1, n) es

main = interact $ solve.map toEdge.map (map read.words).lines
  where toEdge [x, y] = (x, y)

-- восстановить дерево по входным данным
-- сравнить число ребер с числом вершин и проверить связность (дфс)
--6 6
--6 3
--6 4
--5 1
--2 5
--1 4
--5 4

import Data.Graph

--main = do
--	vn <- read
--	en <- read

--	edges <- map toInteger (words getContents)
--	print $ length $ components $ buildG edges

findCthulhu :: (Int, Int, [(Int, Int)]) -> String
findCthulhu (vn, en, edges) =
	if vn == en && (length $ components $ buildG (1, vn) edges) == 1
	then "FHTAGN!"
	else "NO"

parseInput :: String -> (Int, Int, [(Int, Int)])
parseInput input = (vn, ve, edges) where
	vn = read $ head $ words $ input
	ve = read $ head $ tail $ words $ input
	edges = pairsFromStrings $ tail $ tail $ words $ input where
		pairsFromStrings [] = []
		pairsFromStrings (f:s:xs) = (read f, read s) : pairsFromStrings xs

--parseInput :: String -> (Int, Int, [(Int, Int)])
--parseInput input = (fst $ head pairs, snd $ head pairs, (tail pairs)) where
--	pairs = pairsFromStrings $ words input
--	pairsFromStrings [] = []
--	pairsFromStrings (f:s:xs) = (read f, read s) : pairsFromStrings xs

--pairsFromStrings :: [String] -> [(Int, Int)]
--pairsFromStrings (f:s:xs) = (read f, read s) : (pairsFromStrings xs)

main = do
	input <- getContents
	print $ findCthulhu $ parseInput input --"6 5 5 6 4 6 3 1 5 1 1 2" --" 6 6 3 6 4 5 1 2 5 1 4 5 4"
	--let pairs = pairsFromStrings $ words text
	--in print $ findCthulhu (fst $ head pairs) (snd $ head pairs) (tail pairs)

	--(1, 6) [(6, 3), (6, 4), (5, 1), (2, 5), (1, 4), (5, 4)]

		--[('*', 6, [3, 4]),
		-- ('*', 3, [6]),
		-- ('*', 4, [6, 1, 5]),
		-- ('*', 5, [1, 2, 4]),
		-- ('*', 1, [5, 4]),
		-- ('*', 2, [5])]

-- восстановить дерево по входным данным
-- сравнить число ребер с числом вершин и проверить связность (дфс)
--6 6
--6 3
--6 4
--5 1
--2 5
--1 4
--5 4

import Data.Graph

--main = do
--	vn <- read
--	en <- read

--	edges <- map toInteger (words getContents)
--	print $ length $ components $ buildG edges

findCthulhu :: (Int, Int, [(Int, Int)]) -> String
findCthulhu (vn, en, edges) =
	if vn == en && (length $ components $ buildG (1, vn) edges) == 1
	then "FHTAGN!"
	else "NO"

parseInput :: String -> (Int, Int, [(Int, Int)])
parseInput input = (vn, ve, edges) where
	vn = read $ head $ words $ input
	ve = read $ head $ tail $ words $ input
	edges = pairsFromStrings $ tail $ tail $ words $ input where
		pairsFromStrings [] = []
		pairsFromStrings (f:s:xs) = (read f, read s) : pairsFromStrings xs

--parseInput :: String -> (Int, Int, [(Int, Int)])
--parseInput input = (fst $ head pairs, snd $ head pairs, (tail pairs)) where
--	pairs = pairsFromStrings $ words input
--	pairsFromStrings [] = []
--	pairsFromStrings (f:s:xs) = (read f, read s) : pairsFromStrings xs

--pairsFromStrings :: [String] -> [(Int, Int)]
--pairsFromStrings (f:s:xs) = (read f, read s) : (pairsFromStrings xs)

main = do
	input <- getContents
	print $ findCthulhu $ parseInput input -- "6 6 6 3 6 4 5 1 2 5 1 4 5 4"
	--let pairs = pairsFromStrings $ words text
	--in print $ findCthulhu (fst $ head pairs) (snd $ head pairs) (tail pairs)

	--(1, 6) [(6, 3), (6, 4), (5, 1), (2, 5), (1, 4), (5, 4)]

		--[('*', 6, [3, 4]),
		-- ('*', 3, [6]),
		-- ('*', 4, [6, 1, 5]),
		-- ('*', 5, [1, 2, 4]),
		-- ('*', 1, [5, 4]),
		-- ('*', 2, [5])]

import Data.List
import Data.String

addEdge' :: Int -> Int -> [[Int]] -> [[Int]]
addEdge' 0 b (g:gs) = ((b:g):gs)
addEdge' a b (g:gs) = g:addEdge' (a-1) b gs

addEdge :: Int -> Int -> [[Int]] -> [[Int]]
addEdge a b g = addEdge' a b $ addEdge' b a g

dropEdge' :: Int -> Int -> [[Int]] -> [[Int]]
dropEdge' 0 b (g:gs) = (delete b g):gs
dropEdge' a b (g:gs) = g:dropEdge' (a-1) b gs

dropEdge :: Int -> Int -> [[Int]] -> [[Int]]
dropEdge a b g = dropEdge' a b $ dropEdge' b a g

getCycle'' :: [Int] -> [[Int]] -> [Int] -> [Int]
getCycle'' [] g stack = []
getCycle'' (v:vs) g stack = if aCycle == []
							then getCycle'' vs g stack
							else aCycle
							where aCycle = getCycle' v g stack

getCycle' :: Int -> [[Int]] -> [Int] -> [Int]
getCycle' v g [] 			= 	getCycle'' (g!!v) g [v]
getCycle' v g stack@(s:sx)  =   if elem v sx
					    	   	then v:takeWhile (\x -> not $ x == v) stack
					    	   	else getCycle'' (delete s $ g!!v) g (v:stack)

getCycle :: [[Int]] -> [Int]
getCycle g = getCycle' 0 g []

reachable' :: [Int] -> [[Int]] -> [Int] -> [Int]
reachable' [] g visited = []
reachable' (v:vs) g visited  =  if elem v visited
							  	then []
								else fromv ++ reachable' vs g (fromv ++ visited)
								where fromv = v:reachable' new g (v:visited); new = (g !! v) \\ visited

reachable :: Int -> [[Int]] -> [Int]
reachable v g = reachable' [v] g []

isConnected :: [[Int]] -> Bool
isConnected g = length g == (length $ reachable 0 g)

hasSingleCycle :: [[Int]] -> Bool
hasSingleCycle g =  if aCycle == []
				    then False
					else [] == getCycle (dropEdge (aCycle !! 0) (aCycle !! 1) g)
				    where aCycle = getCycle g

isKtulhu :: [[Int]] -> Bool
isKtulhu g = isConnected g && hasSingleCycle g

parse :: String -> [Int]
parse s = [read $ w !! 0, read $ w !! 1] where w = words s

parseGraph' :: [[Int]] -> [String] -> [[Int]]
parseGraph' g []     = g
parseGraph' g (s:sx) = parseGraph' (addEdge (e !! 0 - 1) (e !! 1 - 1) g) sx where e = parse s

parseGraph :: String -> [[Int]]
parseGraph s = parseGraph' (replicate ((parse $ head w) !! 0) []) (tail w) where w = lines s

ktulhuState :: Bool -> String
ktulhuState ktulhu = if ktulhu then "FHTAGN!" else "NO"

main = do
		graphData <- getContents
		putStrLn $ ktulhuState $ isKtulhu $ parseGraph $ graphData

import Data.List
import Data.String

addEdge' :: Int -> Int -> [[Int]] -> [[Int]]
addEdge' 0 b (g:gs) = ((b:g):gs)
addEdge' a b (g:gs) = g:addEdge' (a-1) b gs

addEdge :: Int -> Int -> [[Int]] -> [[Int]]
addEdge a b g = addEdge' a b $ addEdge' b a g

dropEdge' :: Int -> Int -> [[Int]] -> [[Int]]
dropEdge' 0 b (g:gs) = (delete b g):gs
dropEdge' a b (g:gs) = g:dropEdge' (a-1) b gs

dropEdge :: Int -> Int -> [[Int]] -> [[Int]]
dropEdge a b g = dropEdge' a b $ dropEdge' b a g

getCycle'' :: [Int] -> [[Int]] -> [Int] -> [Int]
getCycle'' [] g stack = []
getCycle'' (v:vs) g stack = if aCycle == []
							then getCycle'' vs g stack
							else aCycle
							where aCycle = getCycle' v g stack

getCycle' :: Int -> [[Int]] -> [Int] -> [Int]
getCycle' v g [] 			= 	getCycle'' (g!!v) g [v]
getCycle' v g stack@(s:sx)  =   if elem v sx
					    	   	then v:takeWhile (\x -> not $ x == v) stack
					    	   	else getCycle'' (delete s $ g!!v) g (v:stack)

getCycle :: [[Int]] -> [Int]
getCycle g = getCycle' 0 g []

reachable' :: [Int] -> [[Int]] -> [Int] -> [Int]
reachable' [] g visited = []
reachable' (v:vs) g visited  =  if elem v visited
							  	then []
								else fromv ++ reachable' vs g (fromv ++ visited)
								where fromv = v:reachable' new g (v:visited); new = (g !! v) \\ visited

reachable :: Int -> [[Int]] -> [Int]
reachable v g = reachable' [v] g []

isConnected :: [[Int]] -> Bool
isConnected g = length g == (length $ reachable 0 g)

hasSingleCycle :: [[Int]] -> Bool
hasSingleCycle g =  if aCycle == []
				    then False
					else [] == getCycle (dropEdge (aCycle !! 0) (aCycle !! 1) g)
				    where aCycle = getCycle g

isKtulhu :: [[Int]] -> Bool
isKtulhu g = isConnected g && 2 * (length g) == length (concat g)

parse :: String -> [Int]
parse s = [read $ w !! 0, read $ w !! 1] where w = words s

parseGraph' :: [[Int]] -> [String] -> [[Int]]
parseGraph' g []     = g
parseGraph' g (s:sx) = parseGraph' (addEdge (e !! 0 - 1) (e !! 1 - 1) g) sx where e = parse s

parseGraph :: String -> [[Int]]
parseGraph s = parseGraph' (replicate ((parse $ head w) !! 0) []) (tail w) where w = lines s

ktulhuState :: Bool -> String
ktulhuState ktulhu = if ktulhu then "FHTAGN!" else "NO"

main = do
		graphData <- getContents
		putStrLn $ ktulhuState $ isKtulhu $ parseGraph $ graphData


As meticulous Gerald sets the table and caring Alexander sends the postcards, Sergey makes snowmen. Each showman should consist of three snowballs: a big one, a medium one and a small one. Sergey's twins help him: they've already made n snowballs with radii equal to r1, r2, ..., rn. To make a snowman, one needs any three snowballs whose radii are pairwise different. For example, the balls with radii 1, 2 and 3 can be used to make a snowman but 2, 2, 3 or 2, 2, 2 cannot. Help Sergey and his twins to determine what maximum number of snowmen they can make from those snowballs.

The first line contains integer n (1 ≤ n ≤ 105) — the number of snowballs. The next line contains n integers — the balls' radii r1, r2, ..., rn (1 ≤ ri ≤ 109). The balls' radii can coincide.

Print on the first line a single number k — the maximum number of the snowmen. Next k lines should contain the snowmen's descriptions. The description of each snowman should consist of three space-separated numbers — the big ball's radius, the medium ball's radius and the small ball's radius. It is allowed to print the snowmen in any order. If there are several solutions, print any of them.

import Data.Ord
import Control.Applicative
import Data.List
import qualified Data.IntMap as IM

main = do n <- read <$> getLine
          rs <- map read <$> words <$> getLine
          putStrLn $ unlines $ map (unwords.map show) $ solve n $ IM.fromList $ map (\x -> ((fst.head) x,map snd x)) $ groupBy (\ (i,_) (j,_) -> i==j) $ sortBy (comparing fst) $ map (\x -> (length x,head x)) $ group $ sortBy (comparing negate) rs

solve :: Int -> IM.IntMap [Int] -> [[Int]]
solve _ ixs = [(length ans)]:ans
   where ans = map (sortBy (comparing negate)) $ solve' [] ixs
solve' :: [[Int]] -> IM.IntMap [Int] -> [[Int]]
solve' rss ixs = case (f =<< f =<< f =<< (return ([],ixs))) of
                   Nothing -> rss
                   Just (rs@[(x,[r1]),(y,[r2]),(z,[r3])],ixs') -> solve' ([r1,r2,r3]:rss) $ foldl insert' ixs' rs

f :: ([(IM.Key,[Int])],IM.IntMap [Int]) -> Maybe ([(IM.Key,[Int])],IM.IntMap [Int])
f (kxss,ixs) = case (IM.maxViewWithKey ixs) of
          Nothing -> Nothing
          Just ((k,[x]), ixs') -> Just ((k,[x]):kxss, ixs')
          Just ((k,(x:xs)), ixs') -> Just ((k,[x]):kxss, IM.insertWith (++) k xs ixs')

insert' :: IM.IntMap [Int] -> (IM.Key,[Int]) -> IM.IntMap [Int]
insert' ixs (1,_) = ixs
insert' ixs (k,[x]) = IM.insertWith (++) (k-1) [x] ixs

import Data.Ord
import Control.Applicative
import Data.List
import Data.IntMap(IntMap,Key)
import qualified Data.IntMap as IM
import qualified Data.ByteString.Char8 as B

main = do n <- read <$> getLine
          rs <- map read' <$> B.words <$> B.getLine
          putStrLn $ unlines $ map (unwords.map show) $ solve n $ IM.fromList $ map (\x -> ((fst.head) x,map snd x)) $ groupBy (\ (i,_) (j,_) -> i==j) $ sortBy (comparing fst) $ map (\x -> (length x,head x)) $ group $ sortBy (comparing negate) rs

read' s = let Just (n,_) = B.readInt s
          in n

solve :: Int -> IntMap [Int] -> [[Int]]
solve _ ixs = [(length ans)]:ans
   where ans = map (sortBy (comparing negate)) $ solve' [] ixs
solve' :: [[Int]] -> IntMap [Int] -> [[Int]]
solve' rss ixs = case (f =<< f =<< f =<< (return ([],ixs))) of
                   Nothing -> rss
                   Just (rs@[(x,[r1]),(y,[r2]),(z,[r3])],ixs') -> solve' ([r1,r2,r3]:rss) $ foldl insert' ixs' rs

f :: ([(Key,[Int])],IntMap [Int]) -> Maybe ([(Key,[Int])],IntMap [Int])
f (kxss,ixs) = case (IM.maxViewWithKey ixs) of
          Nothing -> Nothing
          Just ((k,[x]), ixs') -> Just ((k,[x]):kxss, ixs')
          Just ((k,(x:xs)), ixs') -> Just ((k,[x]):kxss, IM.insertWith (++) k xs ixs')

insert' :: IM.IntMap [Int] -> (IM.Key,[Int]) -> IM.IntMap [Int]
insert' ixs (1,_) = ixs
insert' ixs (k,[x]) = IM.insertWith (++) (k-1) [x] ixs

import Data.Ord
import Control.Applicative
import Data.List
import qualified Data.IntMap as IM

main = do n <- read <$> getLine
          rs <- map read <$> words <$> getLine
          putStrLn $ unlines $ map (unwords.map show) $ solve n $ IM.fromList $ map (\x -> ((fst.head) x,map snd x)) $ groupBy (\ (i,_) (j,_) -> i==j) $ map (\x -> (length x,head x)) $ group $ sortBy (comparing negate) rs

solve :: Int -> IM.IntMap [Int] -> [[Int]]
solve _ ixs = [(length ans)]:ans
   where ans = map (sortBy (comparing negate)) $ solve' [] ixs
solve' :: [[Int]] -> IM.IntMap [Int] -> [[Int]]
solve' rss ixs = case (f =<< f =<< f =<< (return ([],ixs))) of
                   Nothing -> rss
                   Just (rs@[(x,[r1]),(y,[r2]),(z,[r3])],ixs') -> solve' ([r1,r2,r3]:rss) $ foldl insert' ixs' rs

f :: ([(IM.Key,[Int])],IM.IntMap [Int]) -> Maybe ([(IM.Key,[Int])],IM.IntMap [Int])
f (kxss,ixs) = case (IM.maxViewWithKey ixs) of
          Nothing -> Nothing
          Just ((k,[x]), ixs') -> Just ((k,[x]):kxss, ixs')
          Just ((k,(x:xs)), ixs') -> Just ((k,[x]):kxss, IM.insert k xs ixs')

insert' :: IM.IntMap [Int] -> (IM.Key,[Int]) -> IM.IntMap [Int]
insert' ixs (1,xs) = ixs
insert' ixs (k,xs) = IM.insert k xs ixs

import Control.Applicative ((<$>))
import Data.List (group,sortBy)

main = do
  n <- read <$> getLine
  rs <- map read <$> words <$> getLine
  putStrLn $ solve n $ map (\x->(length x,x)) $ group $ sortBy rev rs

rev :: Int -> Int -> Ordering
rev x y = compare (-x) (-y)

solve :: Int -> [(Int,[Int])] -> String
solve _ rs = unlines $ [(show n)] ++ (map (unwords.map show.sortBy rev) rs')
   where rs' = f $ sortBy (\x y -> rev (fst x) (fst y)) rs
         n = length rs'

f :: [(Int,[Int])] -> [[Int]]
f [] = []
f [x] = []
f [x,y] = []
f (xxs:yys:zzs:wss) = xyz : f xyzs'
   where xyz = map (head.snd) [xxs,yys,zzs]
         xyzs = map (\ (i,xs) -> (pred i,tail xs))  [xxs,yys,zzs]
         xyzs' = foldl (flip insert) wss xyzs

insert :: (Int,[Int]) -> [(Int,[Int])] -> [(Int,[Int])]
insert (_,[]) yss = yss
insert (0,_)  yss = yss
insert (i,xxs@(x:xs)) yss = zss ++ [(i,xxs)] ++ wss
   where (zss,wss) = span (\ (k,(l:_)) -> (k>i)||((k<=i)&&(l>x))) yss

import Control.Applicative
import Data.List

main = do
  n <- read <$> getLine
  rs <- map read <$> words <$> getLine
  putStrLn $ solve n $ group $ sortBy (\x y -> compare (-x) (-y)) rs

solve :: Int -> [[Int]] -> String
solve _ rs = unlines $ [(show n)] ++ (map (unwords.map show) rs')
   where rs' = f rs
         n = length rs'

f [] = []
f [x] = []
f [x,y] = []
f (xxs:yys:zzs:wss) = hxyz:(f $ (filter (not.null) txyzs)++wss)
   where hxyz = map head [xxs,yys,zzs]
         txyzs = map tail [xxs,yys,zzs]