According to a new ISO standard, a flag of every country should have a chequered field n × m, each square should be of one of 10 colours, and the flag should be «striped»: each horizontal row of the flag should contain squares of the same colour, and the colours of adjacent horizontal rows should be different. Berland's government asked you to find out whether their flag meets the new ISO standard.

The first line of the input contains numbers n and m (1 ≤ n, m ≤ 100), n — the amount of rows, m — the amount of columns on the flag of Berland. Then there follows the description of the flag: each of the following n lines contain m characters. Each character is a digit between 0 and 9, and stands for the colour of the corresponding square.

Output YES, if the flag meets the new ISO standard, and NO otherwise.

-- https://codeforces.com/problemset/problem/16/A

import Control.Applicative ((<$>))
import Control.Monad (replicateM)
import Data.Char(digitToInt)

getLines :: Int -> IO [String]
getLines n = replicateM n getLine

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

testCols :: [Char] -> Bool
testCols [a, b] = a /= b
testCols (a:b:xs) = (a /= b) && testCols (b:xs)

workProblem :: IO ()
workProblem = do
                [n, m] <- readLine :: IO [Int]
                input <- getLines n
                let cols = map head input
                let rowTest = and $ map (\xs -> and $ map (== head xs) (tail xs)) input
                let colTest = if length cols == 1 then True else  testCols cols
                let anwser = if rowTest && colTest then "YES" else "NO"
                () <- putStrLn anwser
                return ()

main :: IO ()
main = workProblem

main = do
	dummy <- getLine
	todo <- getContents
	putStrLn $ if gao (lines todo) then "YES" else "NO"

gao [] = True
gao (a:b) = gao b && a == take (length a) (repeat (head a)) && (b == [] || a /= head b)

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}

import Control.Monad

import Data.IORef
import System.IO.Unsafe

import Data.List
import Data.Ratio

solve = do n <- cin
           m <- cin :: IO Int
           rows <- replicateM n cin :: IO [String]
           let a = all (null.tail.nub) rows
               b = not . or . zipWith (==) rows $ tail rows
           return . output $ a && b
  where
    output True = "YES"
    output False = "NO"

main = putStrLn =<< solve

class Read' a where
  read' :: String -> a

instance Read' Integer where
  read' = read

instance Read' Int where
  read' = read

instance Read' Double where
  read' = read

instance Read' Char where
  read' (c:[]) = c
  read' cs = error $ cs ++ " cannot read' as the type of Char."

instance Read' String where
  read' cs = cs

cin :: forall a. Read' a => IO a
cin = do (x:xs) <- readIORef input
         writeIORef input xs
         return $ read' x

input :: IORef [String]
input = unsafePerformIO $ getContents >>= newIORef . words

solve [] = []
solve (s:ss) = map (head s==) s ++ [nextline]++ solve ss
   where nextline = if null ss then True
   	                else s /= (head ss)

main = do
	a <-getLine
	c <-getContents
	if and (solve (lines c)) then putStrLn "YES"
	else putStrLn "NO"

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

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

isSame (x:xs) = all (==x) xs

isNotSame :: String -> Bool
isNotSame [x] = True
isNotSame (a:b:c) = (a /= b) && (isNotSame (b:c))

main = do
    s <- getLine
    let n:_ = un s
    ss <- getLines n
    let res = if (all isSame ss) && (isNotSame (map head ss)) then "YES" else "NO"
    putStrLn res

main = do
    haha <- getLine
    flag <- getContents

    putStrLn $ if yao (lines flag) then "YES" else "NO"

yao []      = True
yao (x:xs)  = yao xs && x == take (length x) (repeat (head x) ) && (xs == [] ||x /= head xs)

splitOnPred :: (Eq a) => (a -> Bool) -> [a] -> [[a]]
splitOnPred pred xs = splitOn' xs [] []
  where splitOn' [] m ret = if null m then ret else ret ++ [m]
        splitOn' (x:xs) [] ret = splitOn' xs (if pred x then [] else [x]) ret
        splitOn' (x:xs) m  ret = if pred x then splitOn' xs [] (ret ++ [m]) else splitOn' xs (m ++ [x]) ret

splitOn :: String -> String -> [String]
splitOn str sp = splitOnPred (\x -> elem x sp) str

split :: String -> [String]
split str = splitOn str " \n"

solve :: [[Char]] -> Bool
solve g = column g && row g
  where
    column :: [[Char]] -> Bool
    column g = let gg = map (\x -> ((head x), x)) g
                   ok = map (\(x, y) -> all (== x) y) gg
               in and ok
    row    g = let gg = map head g
               in row' gg
                 where row' (x:y:xs)
                         | x /= y    = row' (y:xs)
                         | otherwise = False
                       row' _ = True

main :: IO ()
main = do cs <- getContents
          let sp = split cs
              m  = read (sp !! 0) :: Int
              n  = read (sp !! 1) :: Int
              g  = drop 2 sp
            in putStrLn $ if solve g then "Yes" else "No"

import List (nub)

(<?>) :: a -> a -> Bool -> a
(<?>) a b p  =  if p then a else b

solve :: [String] -> Bool
solve xs  =  all ((== 1) . length . nub) xs
    && all (\(a, b) -> a /= b) (zip xs (tail xs))

main :: IO ()
main  =  do
    n  <-  fmap (head . map read . words) getLine
    lines'  <-  fmap (take n . lines) getContents
    putStrLn . ("YES" <?> "NO") . solve $ lines'

import System.Environment
import Control.Monad
import Control.Monad (liftM, sequence)
import Data.List

rr :: [Char] -> Integer
rr = read

okh [] = True
okh (x:[]) = True
okh (x:y:xs) = if x/=y then False else okh (y:xs)

okv [] = True
okv (x:[]) = True
okv (x:y:xs) = if x==y then False else okv (y:xs)

yesno True = "YES"
yesno False = "NO"

main = do
    s <- getLine
    let (n:m:null) = Prelude.map rr $ words s
    z <- lines `liftM` getContents
    putStrLn $ yesno $ okv z && Data.List.foldl1(&&) (map okh z)

import Data.List (group)
import Control.Monad

yesOrNo :: Bool -> IO ()
yesOrNo True = putStrLn "YES"
yesOrNo False = putStrLn "NO"

solve :: [String] -> Bool
solve xs = (and $ map check1 xs) && (check2 $ map head xs)
    where
        check1 xs = length (group xs) == 1
        check2 xs = length (group xs) == length xs

main = do
    getContents >>= (yesOrNo . solve . tail . lines)

import Data.List

main :: IO()
main = do
    _ <- getLine
    todo <- getContents
    putStrLn $ if gao (lines todo) then "YES" else "NO"

gao :: [String] -> Bool
gao a = f a && (g $ transpose a)
    where
        f a = all (==1) [ if (any (==True) $ map (/=head x) x) then 0 else 1 | x <- a ]
        g a = all (==1) [ if adj x then 0 else 1 | x <- a ]
            where
                adj [x] = False
                adj [x, y] = x == y
                adj [x, y, z] = x == y || y == z
                adj (x:y:z) = x == y || adj (y:z)

import Data.List( nub, group )
main:: IO ()
main = do
    tokens <- return . words =<< getContents
    let rows = read $ tokens!!0
        lines = drop 2 tokens
        tmp = unzip $ map linechk lines
        colorseq = fst tmp
        horizontalchk = and $ snd tmp
        verticalchk = rows == (length $ group colorseq)
    if horizontalchk && verticalchk
        then putStr "YES"
        else putStr "NO"

linechk     :: String -> (Char,Bool)
linechk l   =  (head l, 1 == (length . nub)  l)

import Control.Monad
import Data.Char
import Data.List
import Data.Maybe

getLines :: Int -> IO [String]
getLines n = replicateM n getLine

splitByPredicate :: (a -> Bool) -> [a] -> [[a]]
splitByPredicate _ [] = []
splitByPredicate p l
    | p (head l) == True = [takeWhile p l] ++ (splitByPredicate p (dropWhile p l))
    | otherwise          = [takeWhile (not . p) l] ++ (splitByPredicate p (dropWhile (not . p) l))

allEqual :: (Eq a) => [a] -> Bool
allEqual []         = True
allEqual [x]        = True
allEqual (x: y: xs) = (x == y) && allEqual (y: xs)

check1 :: [String] -> Bool
check1 = all allEqual

check2 :: [String] -> Bool
check2 []         = True
check2 [x]        = True
check2 (x: y: xs) = ((x !! 0) /= (y !! 0)) && check2 (y: xs)

solve :: [String] -> String
solve ls
   |  check1 ls && check2 ls = "YES"
   |  otherwise              = "NO"

main = do
    sn <- getLine
    let [n, m] = map read (words sn)
    sl <- getLines n
    putStrLn $ solve sl

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

main = do
		[n,m]<-map read <$> words <$> getLine ::IO [Int]
		s<- replicateM n getLine
		let x = all (==1) $ map length $ map group s
		let y = all (==1) $ map length $ group $ head $ transpose s
		putStrLn $ if x && y then "YES" else "NO"

import Data.List

main :: IO()
main = showBool . check . tail . lines =<< getContents

showBool :: Bool -> IO()
showBool True  = putStrLn "YES"
showBool False = putStrLn "NO"

check :: [String] -> Bool
check flag = (checkRow flag) && (checkColumn flag)

checkRow :: [String] -> Bool
checkRow = all (\x -> (length . group) x == 1)

checkColumn :: [String] -> Bool
checkColumn flag = all id . zipWith (/=) rows $ (tail rows)
    where rows = map head flag

main = do
    inp <- getContents
    let ln = lines inp
    let sol = check ' ' $ tail ln
    if sol
        then putStrLn "YES"
        else putStrLn "NO"

check c [] = True
check c (x:xs) = (x!!0 /= c) && (allEq x) && (check (x!!0) xs)
    where
    allEq s = (fil s) == []
    fil s = filter (/= (head s)) $ tail s

import Data.List

main :: IO()
main = do
    _ <- getLine
    todo <- getContents
    putStrLn $ if gao (lines todo) then "YES" else "NO"

gao :: [String] -> Bool
gao a = f a && (g $ transpose a)
    where
        f a = all (==1) [ if (any (==True) $ map (/=head x) x) then 0 else 1 | x <- a ]
        g a = all (==1) [ if adj x then 0 else 1 | x <- a ]
            where
                adj [x] = True
                adj [x, y] = x == y
                adj [x, y, z] = x == y && y == z
                adj (x:y:z) = x == y && adj (y:z)


You are given an array $$$a$$$ consisting of $$$n$$$ integers.You can remove at most one element from this array. Thus, the final length of the array is $$$n-1$$$ or $$$n$$$.Your task is to calculate the maximum possible length of the strictly increasing contiguous subarray of the remaining array.Recall that the contiguous subarray $$$a$$$ with indices from $$$l$$$ to $$$r$$$ is $$$a[l \dots r] = a_l, a_{l + 1}, \dots, a_r$$$. The subarray $$$a[l \dots r]$$$ is called strictly increasing if $$$a_l < a_{l+1} < \dots < a_r$$$.

The first line of the input contains one integer $$$n$$$ ($$$2 \le n \le 2 \cdot 10^5$$$) — the number of elements in $$$a$$$. The second line of the input contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i \le 10^9$$$), where $$$a_i$$$ is the $$$i$$$-th element of $$$a$$$.

Print one integer — the maximum possible length of the strictly increasing contiguous subarray of the array $$$a$$$ after removing at most one element.

NoteIn the first example, you can delete $$$a_3=5$$$. Then the resulting array will be equal to $$$[1, 2, 3, 4]$$$ and the length of its largest increasing subarray will be equal to $$$4$$$.

main :: IO()
main = interact $ show . f . map read . words . last . lines

f :: [Int] -> Int
f = maximum . (\ (_, _, wtf2) -> map (uncurry max) wtf2) . foldr wtf (0, 0, [])
  where
    wtf :: Int -> (Int, Int, [(Int, Int)]) -> (Int, Int, [(Int, Int)])
    wtf x (y, _, []) = (x, y, [(1, 0)])
    wtf x (y, _, [(a, b)]) = (x, y, (if x < y then a + 1 else 1, 1):[(a, b)])
    wtf x (y, z, (a, b):(c, d):as) = (x, y, (if x < y then a + 1 else 1, max (if x < z then c + 1 else 1) (if x < y then b + 1 else 1)):(a, b):(c, d):as)


An important meeting is to be held and there are exactly $$$n$$$ people invited. At any moment, any two people can step back and talk in private. The same two people can talk several (as many as they want) times per meeting.Each person has limited sociability. The sociability of the $$$i$$$-th person is a non-negative integer $$$a_i$$$. This means that after exactly $$$a_i$$$ talks this person leaves the meeting (and does not talk to anyone else anymore). If $$$a_i = 0$$$, the $$$i$$$-th person leaves the meeting immediately after it starts.A meeting is considered most productive if the maximum possible number of talks took place during it.You are given an array of sociability $$$a$$$, determine which people should talk to each other so that the total number of talks is as large as possible.

The first line contains an integer $$$t$$$ ($$$1 \le t \le 1000$$$) — the number of test cases. The next $$$2t$$$ lines contain descriptions of the test cases. The first line of each test case description contains an integer $$$n$$$ ($$$2 \le n \le 2 \cdot 10^5$$$) —the number of people in the meeting. The second line consists of $$$n$$$ space-separated integers $$$a_1, a_2, \dots, a_n$$$ ($$$0 \le a_i \le 2 \cdot 10^5$$$) — the sociability parameters of all people.  It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$2 \cdot 10^5$$$. It is also guaranteed that the sum of all $$$a_i$$$ (over all test cases and all $$$i$$$) does not exceed $$$2 \cdot 10^5$$$.

Print $$$t$$$ answers to all test cases. On the first line of each answer print the number $$$k$$$ — the maximum number of talks possible in a meeting. On each of the next $$$k$$$ lines print two integers $$$i$$$ and $$$j$$$ ($$$1 \le i, j \le n$$$ and $$$i \neq j$$$) — the numbers of people who will have another talk. If there are several possible answers, you may print any of them.

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 hiding (insert)
--import Data.Array.Unboxed

data PQ t = Empty | PQ !t !Int (PQ t) (PQ t) -- maxiphobic persistent max-heap

size :: PQ t -> Int
size Empty = 0
size (PQ _val sz _l _r) = sz

m3 :: t -> PQ t -> PQ t -> PQ t
m3 val ls rs = let
  lsz = size ls
  rsz = size rs
  totSz = 1 + size ls + size rs
  in  if  lsz <= rsz
  then  PQ val totSz ls rs
  else  PQ val totSz rs ls

merge :: Ord t => PQ t -> PQ t -> PQ t
merge Empty y = y
merge x Empty = x
merge px@(PQ x _xsz xl xr) py@(PQ y ysz _yl _yr) = if  x < y
  then  merge py px
  else  if  ysz >= size xr
  then  m3 x (merge xl xr) py
  else  m3 x (merge xl py) xr

pop :: Ord t => PQ t -> Maybe (t, PQ t)
pop Empty = Nothing
pop (PQ v _ vl vr) = Just (v, merge vl vr)

single :: t -> PQ t
single x = PQ x 1 Empty Empty

insert :: Ord t => t -> PQ t -> PQ t
insert = merge . single

fromList :: Ord t => [t] -> PQ t
fromList = foldr insert Empty

mainFun :: SO
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    a <- getInts n
    let
      pq = fromList $ zip a [1..]
      step pq1 = do
        ((x, ix), pq2) <- pop pq1
        ((y, iy), pq3) <- pop pq2
        guard $ y > 0
        Just ([ix, iy], insert (x-1, ix) $ insert (y-1, iy) pq3)
      ans = unfoldr step pq
    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


You have got a new job, and it's very interesting, you are a ship captain. Your first task is to move your ship from one point to another point, and for sure you want to move it at the minimum cost.And it's well known that the shortest distance between any 2 points is the length of the line segment between these 2 points. But unfortunately there is an island in the sea, so sometimes you won't be able to move your ship in the line segment between the 2 points.You can only move to safe points. A point is called safe if it's on the line segment between the start and end points, or if it's on the island's edge.But you are too lucky, you have got some clever and strong workers and they can help you in your trip, they can help you move the ship in the sea and they will take 1 Egyptian pound for each moving unit in the sea, and they can carry the ship (yes, they are very strong) and walk on the island and they will take 2 Egyptian pounds for each moving unit in the island. The money which you will give to them will be divided between all workers, so the number of workers does not matter here.You can move your ship on the island edge, and it will be considered moving in the sea.Now you have a sea map, and you have to decide what is the minimum cost for your trip.Your starting point is (xStart, yStart), and the end point is (xEnd, yEnd), both points will be different.The island will be a convex polygon and there will be no more than 2 polygon points on the same line, also the starting and the end points won't be inside or on the boundary of the island. The points for the polygon will be given in the anti-clockwise order.

The first line contains 4 integers, xStart, yStart, xEnd and yEnd ( - 100 ≤ xStart, yStart, xEnd, yEnd ≤ 100). The second line contains an integer n, which is the number of points in the polygon (3 ≤ n ≤ 30), followed by a line containing n pairs of integers x and y, which are the coordinates of the points ( - 100 ≤ x, y ≤ 100), the polygon points will be distinct.

Print one line which contains the minimum possible cost. The absolute or relative error in the answer should not exceed 10 - 6.

import Control.Applicative
import Data.Function
import Data.List

data Point = Point Double Double deriving (Eq)
data Segment = Segment { segmentStart, segmentEnd :: Point } deriving (Eq)
data Vector = Vector Double Double

getWords = map read . words <$> getLine

splitEvery n = unfoldr $ \xs -> if null xs then Nothing else Just $ splitAt n xs
getPoints = map (\[a, b] -> Point a b) . splitEvery 2 <$> getWords

cross (Vector x1 y1) (Vector x2 y2) = x1*y2 - x2*y1
dot (Vector x1 y1) (Vector x2 y2) = x1*x2 + y1*y2
sub (Point px py) (Point qx qy) = Vector (qx - px) (qy - py)

intersects s@(Segment p1 p2) t@(Segment p3 p4) =
		(d1 > 0 && d2 < 0 || d1 < 0 && d2 > 0) &&
		(d3 > 0 && d4 < 0 || d3 < 0 && d4 > 0) ||
		d1 == 0 && onSegment p1 t ||
		d2 == 0 && onSegment p2 t ||
		d3 == 0 && onSegment p3 s ||
		d4 == 0 && onSegment p4 s
	where
		direction p q r = sub p r `cross` sub p q

		onSegment (Point rx ry) (Segment (Point px py) (Point qx qy)) =
			min px qx <= rx && rx <= max px qx &&
			min py qy <= ry && ry <= max py qy

		d1 = direction p3 p4 p1
		d2 = direction p3 p4 p2
		d3 = direction p1 p2 p3
		d4 = direction p1 p2 p4

data Line = Line Point Point

onLine r (Line p q) = sub p q `cross` sub p r == 0

intersectsRay s@(Segment p1 p2) t@(Segment p3 p4) =
	intersects s t && not (p3 `onLine` Line p1 p2)

intersection s@(Segment sa sb) t@(Segment ta tb) =
		sa `add` (c `mult` (sa `sub` sb))
	where
		mult a (Vector x y) = Vector (a * x) (a * y)
		add (Point px py) (Vector vx vy) = Point (px + vx) (py + vy)
		c = (sub sa ta `cross` sub ta tb) / (sub sa sb `cross` sub ta tb)

distance (Point px py) (Point qx qy) = sqrt $ (qx - px) ** 2 + (qy - py) ** 2

solve start end polygon
		| length intersecting < 2 = start `distance` end
		| otherwise =
			start `distance` i1 +
			minimum [distThrough, distAround1, distAround2] +
			i2 `distance` end
	where
		startEnd = Segment start end
		segments = zipWith Segment polygon $ tail polygon ++ [head polygon]

		intersecting = filter (startEnd `intersectsRay`) segments
		intersections = map (intersection startEnd) intersecting

		(s1,i1):(s2,i2):_ = sortBy (compare `on` (distance start . snd)) $
				intersecting `zip` intersections

		distThrough = 2 * (i1 `distance` i2)

		distAround s1 s2 segments = sum $ map (\(Segment p q) -> p `distance` q) $
			takeWhile (/= s2) $ tail $ dropWhile (/= s1) $ segments ++ segments

		distAround1 =
			i1 `distance` segmentEnd s1 +
			distAround s1 s2 segments +
			segmentStart s2 `distance` i2

		distAround2 =
			i1 `distance` segmentStart s1 +
			distAround s1 s2 (reverse segments) +
			segmentEnd s2 `distance` i2

main = do
	[start, end] <- getPoints
	_ <- getLine
	polygon <- getPoints
	print $ solve start end polygon

import Control.Applicative
import Data.Function
import Data.List

data Point = Point Double Double deriving (Eq)
data Segment = Segment { segmentStart, segmentEnd :: Point } deriving (Eq)
data Vector = Vector Double Double

getWords = map read . words <$> getLine

splitEvery n = unfoldr $ \xs -> if null xs then Nothing else Just $ splitAt n xs
getPoints = map (\[a, b] -> Point a b) . splitEvery 2 <$> getWords

cross (Vector x1 y1) (Vector x2 y2) = x1*y2 - x2*y1
dot (Vector x1 y1) (Vector x2 y2) = x1*x2 + y1*y2
sub (Point px py) (Point qx qy) = Vector (qx - px) (qy - py)

intersects s@(Segment p1 p2) t@(Segment p3 p4) =
		(d1 > 0 && d2 < 0 || d1 < 0 && d2 > 0) &&
		(d3 > 0 && d4 < 0 || d3 < 0 && d4 > 0) ||
		d1 == 0 && onSegment p1 t ||
		d2 == 0 && onSegment p2 t ||
		d3 == 0 && onSegment p3 s ||
		d4 == 0 && onSegment p4 s
	where
		direction p q r = sub p r `cross` sub p q

		onSegment (Point rx ry) (Segment (Point px py) (Point qx qy)) =
			min px qx <= rx && rx <= max px qx &&
			min py qy <= ry && ry <= max py qy

		d1 = direction p3 p4 p1
		d2 = direction p3 p4 p2
		d3 = direction p1 p2 p3
		d4 = direction p1 p2 p4

data Line = Line Point Point

onLine r (Line p q) = sub p q `cross` sub p r == 0

intersectsRay s@(Segment p1 p2) t@(Segment p3 p4) =
	intersects s t && not (p3 `onLine` (Line p1 p2))

intersection s@(Segment sa sb) t@(Segment ta tb) =
		sa `add` (c `mult` (sa `sub` sb))
	where
		mult a (Vector x y) = Vector (a * x) (a * y)
		add (Point px py) (Vector vx vy) = Point (px + vx) (py + vy)
		c = (sub sa ta `cross` sub ta tb) / (sub sa sb `cross` sub ta tb)

distance (Point px py) (Point qx qy) = sqrt $ (qx - px) ** 2 + (qy - py) ** 2

solve start end polygon
		| length intersecting < 2 = start `distance` end
		| otherwise =
			start `distance` i1 +
			minimum [distThrough, distAround1, distAround2] +
			i2 `distance` end
	where
		startEnd = Segment start end
		segments = zipWith Segment polygon $ tail polygon ++ [head polygon]

		intersecting = filter (startEnd `intersectsRay`) segments
		intersections = map (intersection startEnd) intersecting

		(s1,i1):(s2,i2):_ = sortBy (compare `on` (distance start . snd)) $
				intersecting `zip` intersections

		distThrough = 2 * (i1 `distance` i2)

		distAround s1 s2 segments = sum $ map (\(Segment p q) -> p `distance` q) $
			takeWhile (/= s2) $ tail $ dropWhile (/= s1) $ segments ++ segments

		distAround1 =
			i1 `distance` segmentEnd s1 +
			distAround s1 s2 segments +
			segmentStart s2 `distance` i2

		distAround2 =
			i1 `distance` segmentStart s1 +
			distAround s1 s2 (reverse segments) +
			segmentEnd s2 `distance` i2

main = do
	[start, end] <- getPoints
	_ <- getLine
	polygon <- getPoints
	print $ solve start end polygon

import Control.Applicative
import Data.Function
import Data.List
import Debug.Trace

data Point = Point Double Double deriving (Eq, Show)
data Segment = Segment { segmentStart, segmentEnd :: Point } deriving (Eq, Show)
data Vector = Vector Double Double

getWords = map read . words <$> getLine

splitEvery n = unfoldr $ \xs -> if null xs then Nothing else Just $ splitAt n xs
getPoints = map (\[a, b] -> Point a b) . splitEvery 2 <$> getWords

cross (Vector x1 y1) (Vector x2 y2) = x1*y2 - x2*y1
dot (Vector x1 y1) (Vector x2 y2) = x1*x2 + y1*y2
sub (Point px py) (Point qx qy) = Vector (qx - px) (qy - py)

intersects s@(Segment p1 p2) t@(Segment p3 p4) =
		(d1 > 0 && d2 < 0 || d1 < 0 && d2 > 0) &&
		(d3 > 0 && d4 < 0 || d3 < 0 && d4 > 0) ||
		d1 == 0 && onSegment p1 t ||
		d2 == 0 && onSegment p2 t ||
		d3 == 0 && onSegment p3 s ||
		d4 == 0 && onSegment p4 s
	where
		direction p q r = sub p r `cross` sub p q

		onSegment (Point rx ry) (Segment (Point px py) (Point qx qy)) =
			min px qx <= rx && rx <= max px qx &&
			min py qy <= ry && ry <= max py qy

		d1 = direction p3 p4 p1
		d2 = direction p3 p4 p2
		d3 = direction p1 p2 p3
		d4 = direction p1 p2 p4

data Line = Line Point Point

onLine r (Line p q) = sub p q `cross` sub p r == 0

intersectsRay s@(Segment p1 p2) t@(Segment p3 p4) =
	intersects s t && not (p3 `onLine` (Line p1 p2))

intersection s@(Segment sa sb) t@(Segment ta tb) =
		sa `add` (c `mult` (sa `sub` sb))
	where
		mult a (Vector x y) = Vector (a * x) (a * y)
		add (Point px py) (Vector vx vy) = Point (px + vx) (py + vy)
		c = (sub sa ta `cross` sub ta tb) / (sub sa sb `cross` sub ta tb)

distance (Point px py) (Point qx qy) = sqrt $ (qx - px) ** 2 + (qy - py) ** 2

solve start end polygon
		| length intersecting < 2 = start `distance` end
		| otherwise =
			start `distance` i1 +
			minimum [distThrough, distAround1, distAround2] +
			i2 `distance` end
	where
		startEnd = Segment start end
		segments = zipWith Segment polygon $ tail polygon ++ [head polygon]

		intersecting = filter (startEnd `intersectsRay`) segments
		intersections = map (intersection startEnd) intersecting

		(s1,i1):(s2,i2):_ = sortBy (compare `on` (distance start . snd)) $
				intersecting `zip` intersections

		distThrough = 2 * (i1 `distance` i2)

		distAround s1 s2 segments = sum $ map (\(Segment p q) -> p `distance` q) $
			takeWhile (/= s2) $ tail $ dropWhile (/= s1) $ segments ++ segments

		distAround1 =
			i1 `distance` (segmentEnd s1) +
			(distAround s1 s2 segments) +
			(segmentStart s2) `distance` i2

		distAround2 =
			i1 `distance` (segmentStart s1) +
			(distAround s1 s2 $ reverse segments) +
			(segmentEnd s2) `distance` i2

main = do
	[start, end] <- getPoints
	_ <- getLine
	polygon <- getPoints
	print $ solve start end polygon


Kostya is playing the computer game Cookie Clicker. The goal of this game is to gather cookies. You can get cookies using different buildings: you can just click a special field on the screen and get the cookies for the clicks, you can buy a cookie factory, an alchemy lab, a time machine and it all will bring lots and lots of cookies.At the beginning of the game (time 0), Kostya has 0 cookies and no buildings. He has n available buildings to choose from: the i-th building is worth ci cookies and when it's built it brings vi cookies at the end of each second. Also, to make the game more interesting to play, Kostya decided to add a limit: at each moment of time, he can use only one building. Of course, he can change the active building each second at his discretion.It's important that Kostya is playing a version of the game where he can buy new buildings and change active building only at time moments that are multiples of one second. Kostya can buy new building and use it at the same time. If Kostya starts to use a building at the time moment t, he can get the first profit from it only at the time moment t + 1.Kostya wants to earn at least s cookies as quickly as possible. Determine the number of seconds he needs to do that.

The first line contains two integers n and s (1 ≤ n ≤ 2·105, 1 ≤ s ≤ 1016) — the number of buildings in the game and the number of cookies Kostya wants to earn. Each of the next n lines contains two integers vi and ci (1 ≤ vi ≤ 108, 0 ≤ ci ≤ 108) — the number of cookies the i-th building brings per second and the building's price.

Output the only integer — the minimum number of seconds Kostya needs to earn at least s cookies. It is guaranteed that he can do it.

{-# LANGUAGE FlexibleContexts #-}
import Control.Monad
import Control.Monad.ST.Safe

import Data.Array
import Data.Array.ST.Safe
import Data.Bits
import Data.Function
import Data.Functor
import Data.Int
import Data.List
import Data.Text(pack)
import Data.Text.Read (decimal)

import System.Random

type Slope = Int64
type Value = Int64
type Coord = Int64

type Ray = (Coord, Value, Slope)
type Point = (Coord, Value)
type Building = (Slope, Value)

rayAt :: Ray -> Coord -> Value
rayAt (x0, v0, s) x = v0 + (x - x0) * s

dominates :: Ray -> Point -> Bool
dominates r (x, y) = rayAt r x >= y

isect :: Ray -> Ray -> Coord
isect (x1, v1, s1) (x2, v2, s2) = (x1*s1 - s2*x2 + v2 - v1) `div` (s1 - s2)

-- Returns the most value when the predicate is false
bsearchM :: (Monad m, Num a, Bits a) => (a -> m Bool) -> a -> a -> m a
bsearchM pred l r = go l r
 where
  go l r | l == r - 1 = return l
         | otherwise = do
            let m = (l + r) `shiftR` 1
            p <- pred m
            if p then go l m else go m r

findEnough :: STArray s Int Ray -> Int -> Value -> ST s (Int, Coord, Value)
findEnough arr n cost = do
  i <- bsearchM isEnough 0 n
  (x0, v0, s0) <- readArray arr i
  let xBuy' = x0 + (s0 - 1 + cost - v0) `div` s0
      vBuy' = v0 + (xBuy' - x0) * s0
  if i /= n - 1 then do
    (x1, v1, _) <- readArray arr (i + 1)
    return $ if (xBuy' < x1) then (i, xBuy', vBuy') else (i+1, x1, v1)
  else return (i, xBuy', vBuy')
 where
  isEnough j = do
    (_, v, _) <- readArray arr j
    return $ v > cost

process :: STArray s Int Ray -> Int -> Building -> ST s Int
process arr n b@(slope, cost) = do
  z@(iBuy, xBuy, vBuy) <- findEnough arr n cost
  let newRay' = (xBuy, vBuy - cost, slope)
  insertAfter <- bsearchM (dominates' newRay') iBuy n
  rInsert <- readArray arr insertAfter
  let x = isect newRay' rInsert
      newRay = (x + 1, vBuy - cost + slope * (x + 1 - xBuy), slope)
  writeArray arr (insertAfter + 1) newRay
  return $ insertAfter + 2

 where
  dominates' r j = do
    (x, v, _) <- readArray arr j
    return $ dominates r (x, v)

solve :: [Building] -> Value -> Coord
solve b s = runST $ do
  arr <- newArray (0, n) (0, 0, firstBuildingSlope)
  resultLen <- foldM (process arr) 1 (tail sortedBuildings)
  (_, xAns, _) <- findEnough arr resultLen s
  return xAns
 where
  firstBuildingSlope = fst $ head sortedBuildings
  sortedBuildings = myNubBy ((==) `on` fst) $ mySort b
  n = length b

myNubBy :: (a -> a -> Bool) -> [a] -> [a]
myNubBy _ [] = []
myNubBy f (x:xs) = x:go x xs
 where go x [] = []
       go x (y:ys) = if f x y then go x ys else y:go y ys

mySort :: Ord a => [a] -> [a]
mySort xs = elems $ qsort $ array (0, n-1) $ zip [0..] xs
  where
    n = length xs
    qsort :: Ord a => Array Int a -> Array Int a
    qsort arr = runSTArray $ do
      arr' <- thaw arr
      qsort' arr'
      return arr'
    qsort' :: Ord a => STArray s Int a -> ST s ()
    qsort' a = go 0 n
      where
        go l r = when (l < r - 1) $ do
          let m = (l + r) `shiftR` 1
          pivot <- readArray a m
          let
           loop i j = do
            if (i == j) then return i else do
              vi <- readArray a i
              if vi < pivot then loop (i+1) j else do
                vj <- readArray a j
                writeArray a i vj
                writeArray a j vi
                loop i (j-1)
          newi' <- loop l (r-1)
          x <- readArray a newi'
          let
           newi = if x < pivot then newi' + 1 else newi'
           loop' i j = do
            if (i == j) then return i else do
              vi <- readArray a i
              if vi == pivot then loop' (i+1) j else do
                vj <- readArray a j
                writeArray a i vj
                writeArray a j vi
                loop' i (j-1)
          newj' <- loop' newi (r-1)
          y <- readArray a newj'
          let newj = if y == pivot then newj' + 1 else newj'
          go l newi
          go newj r

tests :: [(Value, [Building], Coord)]
tests = [(9, [(1,0), (2,3), (5,4)], 6),
         (6, [(1,0), (2,2), (5,4)], 5),
         (13,[(1,0), (2,2), (6,5)], 7),
         (10000000000000000, [(1,0)], 10000000000000000)]

oneTest (v, b, ans) = solve b v

randomTest :: Int -> IO ()
randomTest n = do
  b <- replicateM n $ do
    v <- randomRIO (0, 10000)
    c <- randomRIO (0, 100000000)
    return (v, c)
  s <- randomRIO (0, 1000000000000000000)
  print s
  print $ solve b s

genRandom :: Int -> IO ()
genRandom n = do
  s <- randomRIO (0, 1000000000000000000 :: Value)
  putStrLn $ show n ++ " " ++ show s
  replicateM_ n $ do
    v <- randomRIO (1, 10000 :: Slope)
    c <- randomRIO (0, 100000000 :: Value)
    putStrLn $ show v ++ " " ++ show c

--main = randomTest 200000
--main = genRandom 200000
main = z

read' :: Integral a => String -> a
read' = (\(Right (x,_)) -> x) . decimal . pack

z = do
  (n, s)  <- do
    l <- words <$> getLine
    return (read' (l !! 0), read' (l !! 1))

  b <- replicateM n $ do
    [v, c] <- (map read' . words) <$> getLine
    return (v, c)
  print $ solve b s

{-# LANGUAGE FlexibleContexts #-}
import Control.Monad
import Control.Monad.ST.Safe

import Data.Array
import Data.Array.ST.Safe
import Data.Bits
import Data.Function
import Data.Functor
import Data.Int
import Data.List
import Data.Text(pack)
import Data.Text.Read (decimal)

import System.Random

type Slope = Int64
type Value = Int64
type Coord = Int64

type Ray = (Coord, Value, Slope)
type Point = (Coord, Value)
type Building = (Slope, Value)

rayAt :: Ray -> Coord -> Value
rayAt (x0, v0, s) x = v0 + (x - x0) * s

dominates :: Ray -> Point -> Bool
dominates r (x, y) = rayAt r x >= y

isect :: Ray -> Ray -> Coord
isect (x1, v1, s1) (x2, v2, s2) = (x1*s1 - s2*x2 + v2 - v1) `div` (s1 - s2)

-- Returns the most value when the predicate is false
bsearchM :: (Monad m, Num a, Bits a) => (a -> m Bool) -> a -> a -> m a
bsearchM pred l r = go l r
 where
  go l r | l == r - 1 = return l
         | otherwise = do
            let m = (l + r) `shiftR` 1
            p <- pred m
            if p then go l m else go m r

findEnough :: STArray s Int Ray -> Int -> Value -> ST s (Int, Coord, Value)
findEnough arr n cost = do
  i <- bsearchM isEnough 0 n
  (x0, v0, s0) <- readArray arr i
  let xBuy' = x0 + (s0 - 1 + cost - v0) `div` s0
      vBuy' = v0 + (xBuy' - x0) * s0
  if i /= n - 1 then do
    (x1, v1, _) <- readArray arr (i + 1)
    return $ if (xBuy' < x1) then (i, xBuy', vBuy') else (i+1, x1, v1)
  else return (i, xBuy', vBuy')
 where
  isEnough j = do
    (_, v, _) <- readArray arr j
    return $ v > cost

process :: STArray s Int Ray -> Int -> Building -> ST s Int
process arr n b@(slope, value) = do
  z@(iBuy, xBuy, vBuy) <- findEnough arr n (-value)
  let newRay' = (xBuy, vBuy + value, slope)
  insertAfter <- bsearchM (dominates' newRay') iBuy n
  rInsert <- readArray arr insertAfter
  let x = isect newRay' rInsert
      newRay = (x + 1, vBuy + value + slope * (x + 1 - xBuy), slope)
  writeArray arr (insertAfter + 1) newRay
  return $ insertAfter + 2

 where
  dominates' r j = do
    (x, v, _) <- readArray arr j
    return $ dominates r (x, v)

solve :: [Building] -> Value -> Coord
solve b s = runST $ do
  arr <- newArray (0, n) (0, 0, firstBuildingSlope)
  resultLen <- foldM (process arr) 1 (tail sortedBuildings)
  (_, xAns, _) <- findEnough arr resultLen s
  return xAns
 where
  firstBuildingSlope = fst $ head sortedBuildings
  sortedBuildings = myNubBy ((==) `on` fst) $ mySort $ map (\(s, c) -> (s, -c)) b
  n = length b

myNubBy :: (a -> a -> Bool) -> [a] -> [a]
myNubBy _ [] = []
myNubBy f (x:xs) = x:go x xs
 where go x [] = []
       go x (y:ys) = if f x y then go x ys else y:go y ys

mySort :: Ord a => [a] -> [a]
mySort xs = elems $ qsort $ array (0, n-1) $ zip [0..] xs
  where
    n = length xs
    qsort :: Ord a => Array Int a -> Array Int a
    qsort arr = runSTArray $ do
      arr' <- thaw arr
      qsort' arr'
      return arr'
    qsort' :: Ord a => STArray s Int a -> ST s ()
    qsort' a = go 0 n
      where
        go l r = when (l < r - 1) $ do
          let m = (l + r) `shiftR` 1
          pivot <- readArray a m
          let
           loop i j = do
            if (i == j) then return i else do
              vi <- readArray a i
              if vi < pivot then loop (i+1) j else do
                vj <- readArray a j
                writeArray a i vj
                writeArray a j vi
                loop i (j-1)
          newi' <- loop l (r-1)
          x <- readArray a newi'
          let
           newi = if x < pivot then newi' + 1 else newi'
           loop' i j = do
            if (i == j) then return i else do
              vi <- readArray a i
              if vi == pivot then loop' (i+1) j else do
                vj <- readArray a j
                writeArray a i vj
                writeArray a j vi
                loop' i (j-1)
          newj' <- loop' newi (r-1)
          y <- readArray a newj'
          let newj = if y == pivot then newj' + 1 else newj'
          go l newi
          go newj r

tests :: [(Value, [Building], Coord)]
tests = [(9, [(1,0), (2,3), (5,4)], 6),
         (6, [(1,0), (2,2), (5,4)], 5),
         (13,[(1,0), (2,2), (6,5)], 7),
         (10000000000000000, [(1,0)], 10000000000000000)]

oneTest (v, b, ans) = solve b v

randomTest :: Int -> IO ()
randomTest n = do
  b <- replicateM n $ do
    v <- randomRIO (0, 10000)
    c <- randomRIO (0, 100000000)
    return (v, c)
  s <- randomRIO (0, 1000000000000000000)
  print s
  print $ solve b s

genRandom :: Int -> IO ()
genRandom n = do
  s <- randomRIO (0, 1000000000000000000 :: Value)
  putStrLn $ show n ++ " " ++ show s
  replicateM_ n $ do
    v <- randomRIO (1, 10000 :: Slope)
    c <- randomRIO (0, 100000000 :: Value)
    putStrLn $ show v ++ " " ++ show c

--main = randomTest 200000
--main = genRandom 200000
main = z

read' :: Integral a => String -> a
read' = (\(Right (x,_)) -> x) . decimal . pack

z = do
  (n, s)  <- do
    l <- words <$> getLine
    return (read' (l !! 0), read' (l !! 1))

  b <- replicateM n $ do
    [v, c] <- (map read' . words) <$> getLine
    return (v, c)
  print $ solve b s


In this problem at each moment you have a set of intervals. You can move from interval (a, b) from our set to interval (c, d) from our set if and only if c < a < d or c < b < d. Also there is a path from interval I1 from our set to interval I2 from our set if there is a sequence of successive moves starting from I1 so that we can reach I2.Your program should handle the queries of the following two types:  "1 x y" (x < y) — add the new interval (x, y) to the set of intervals. The length of the new interval is guaranteed to be strictly greater than all the previous intervals. "2 a b" (a ≠ b) — answer the question: is there a path from a-th (one-based) added interval to b-th (one-based) added interval? Answer all the queries. Note, that initially you have an empty set of intervals.

The first line of the input contains integer n denoting the number of queries, (1 ≤ n ≤ 105). Each of the following lines contains a query as described above. All numbers in the input are integers and don't exceed 109 by their absolute value. It's guaranteed that all queries are correct.

For each query of the second type print "YES" or "NO" on a separate line depending on the answer.

import Control.Monad
import Control.Applicative
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S

main = do
    n <- read <$> getLine
    loop n 1 M.empty

loop :: Int -> Int -> M.Map Int (Int,Int) -> IO ()
loop 0 _ _ = return ()
loop n i m = do
    c:x:y:_ <- map read . words <$> getLine
    case c of
        1 -> loop (n-1) (i+1) (M.insert i (x,y) m)
        2 -> do
            putStrLn $ if hasPath m x y then "YES" else "NO"
            loop (n-1) i m

hasPath m from to =
    let s = snd $ runState (dfs m from) S.empty in
    S.member to s

dfs m pos = do
    memo <- get
    case S.member pos memo of
        True -> return ()
        False -> do
            let l = next (m M.! pos) (M.assocs m)
            put (S.insert pos memo)
            mapM_ (dfs m) l

next :: (Int,Int) -> [(Int,(Int,Int))] -> [Int]
next (a,b) l = do
    (i,(c,d)) <- l
    if (c < a && a < d) ||  (c < b && b < d) then return i else []

newtype State a = State { runState :: S.Set Int -> (a,S.Set Int) }

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

get = State (\s -> (s,s))
put s = State (\_ -> ((),s))

import Control.Monad (liftM, replicateM)
import Data.Array ((!), listArray)
import Data.Char (ord)
import Data.Graph (buildG, edges, path)
import Data.List (intercalate)

data Query  =  Add Int Int | Path Int Int

solve :: [Query] -> [Bool]
solve qs  =  solve' 1 emptyG qs
  where
    n  =  length $ filter isAdd qs
    segments  =  listArray (1, n) $ filter isAdd qs
    isAdd (Add _ _)  =  True
    isAdd _  =  False
    emptyG  =  buildG (1, 1) []
    solve' k graph []  =  []
    solve' k graph (q:qs)  =  case q of
        (Add a b)  ->  solve' (k+1) graph' qs
        (Path a b)  ->  path graph a b : solve' k graph qs
      where
        graph'  =  buildG (1, k)
            $ edges graph ++ filter intersect ([(i, k) | i <- [1..k-1]] ++ [(k, i) | i <- [1..k-1]])
        intersect (i, j)  =  case (segments ! i, segments ! j) of
            (Add a b, Add c d)  ->  c < a && a < d || c < b && b < d

main :: IO ()
main  =  do
    n  <-  readLn
    qs  <-  replicateM n readQuery
    mapM_ (putStrLn . fromBool) $ solve qs

  where

    fromBool True  =  "YES"
    fromBool False  =  "NO"

    readQuery :: IO Query
    readQuery  =  do
        [q, a, b]  <-  reads
        case q of
            1  ->  return $ Add a b
            2  ->  return $ Path 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')

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections #-}

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

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

rep :: Monad m => Int -> (Int -> m ()) -> m ()
rep !n f=go 0 where go !i=when(i<n)$f i>>go(i+1)
{-# INLINE rep #-}

type Vertex = Int

main :: IO ()
main = do
  n <- readLn
  larr <- newArray (0,n-1) minBound :: IO (IOUArray Vertex Int)
  rarr <- newArray (0,n-1) minBound :: IO (IOUArray Vertex Int)
  used <- newArray (0,n-1) False :: IO (IOUArray Vertex Bool)

  let getInterval i = do
        !l <- unsafeRead larr i
        !r <- unsafeRead rarr i
        return $! (l,r)
  let isVertex (l,r) = (l,r) /= minBound
  let dfs v = do
        (l,r) <- getInterval v
        rep n $ \i-> do
          flg <- unsafeRead used i
          unless flg $ do
            (nl,nr) <- getInterval i
            when (((nl<l&&l<nr)||(nl<r&&r<nr)) && isVertex (nl,nr)) $ do
              unsafeWrite used i True
              dfs i
  let query1 i l r = do
       unsafeWrite larr i l
       unsafeWrite rarr i r
  let query2 start goal = do
        rep n $ \i-> unsafeWrite used i False
        unsafeWrite used start True
        dfs start
        res <- unsafeRead used goal
        if res then putStrLn "YES" else putStrLn "NO"
  let solve qs = go 1 qs
         where
           go !i (1:x:y:rest) = query1 i x y >> go (i+1) rest
           go !i (2:a:b:rest) = query2 a b >> go i rest
           go _ _ = return ()
  B.getContents >>= solve.map readInt.B.words

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections #-}

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

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

rep :: Monad m => Int -> (Int -> m ()) -> m ()
rep !n f=go 0 where go !i=when(i<n)$f i>>go(i+1)
{-# INLINE rep #-}

type Vertex = Int

main :: IO ()
main = do
  n <- readLn
  larr <- newArray (0,n-1) minBound :: IO (IOUArray Vertex Int)
  rarr <- newArray (0,n-1) minBound :: IO (IOUArray Vertex Int)
  used <- newArray (0,n-1) False :: IO (IOUArray Vertex Bool)

  let getInterval i = do
        !l <- unsafeRead larr i
        !r <- unsafeRead rarr i
        return $! (l,r)
  let isVertex (l,r) = (l,r) /= minBound
  let dfs v = do
        (l,r) <- getInterval v
        rep n $ \i-> do
          flg <- unsafeRead used i
          unless flg $ do
            (nl,nr) <- getInterval i
            when (((nl<l&&l<nr)||(nl<r&&r<nr)) && isVertex (nl,nr)) $ do
              unsafeWrite used i True
              dfs i
  let query1 i l r = do
       unsafeWrite larr i l
       unsafeWrite rarr i r
  let query2 start goal = do
        rep n $ \i-> unsafeWrite used i False
        unsafeWrite used start True
        dfs start
        res <- unsafeRead used goal
        if res then putStrLn "YES" else putStrLn "NO"
  let solve qs = go 1 qs
         where
           go !i (1:x:y:rest) = query1 i x y >> go (i+1) rest
           go !i (2:a:b:rest) = query2 a b >> go (i+1) rest
           go _ _ = return ()
  B.getContents >>= solve.map readInt.B.words


A binary string is a string consisting only of the characters 0 and 1. You are given a binary string $$$s_1 s_2 \ldots s_n$$$. It is necessary to make this string non-decreasing in the least number of operations. In other words, each character should be not less than the previous. In one operation, you can do the following: Select an arbitrary index $$$1 \leq i \leq n$$$ in the string; For all $$$j \geq i$$$, change the value in the $$$j$$$-th position to the opposite, that is, if $$$s_j = 1$$$, then make $$$s_j = 0$$$, and vice versa.What is the minimum number of operations needed to make the string non-decreasing?

Each test consists of multiple test cases. The first line contains an integer $$$t$$$ ($$$1 \leq t \leq 10^4$$$) — the number of test cases. The description of test cases follows. The first line of each test cases a single integer $$$n$$$ ($$$1 \leq n \leq 10^5$$$) — the length of the string. The second line of each test case contains a binary string $$$s$$$ of length $$$n$$$. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$2 \cdot 10^5$$$.

For each test case, output a single integer — the minimum number of operations that are needed to make the string non-decreasing.

NoteIn the first test case, the string is already non-decreasing.In the second test case, you can select $$$i = 1$$$ and then $$$s = \mathtt{01}$$$.In the third test case, you can select $$$i = 1$$$ and get $$$s = \mathtt{010}$$$, and then select $$$i = 2$$$. As a result, we get $$$s = \mathtt{001}$$$, that is, a non-decreasing string.In the sixth test case, you can select $$$i = 5$$$ at the first iteration and get $$$s = \mathtt{100001}$$$. Then choose $$$i = 2$$$, then $$$s = \mathtt{111110}$$$. Then we select $$$i = 1$$$, getting the non-decreasing string $$$s = \mathtt{000001}$$$.

import System.IO
import Control.Applicative
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import Data.Functor
import Data.Monoid
import Data.Function (fix)
import Data.Array (Array, array, (!))
import Data.Array.ST
import Data.Array.Unboxed
import Control.Monad.ST as ST
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8

construct :: (BS.ByteString -> Maybe (a, BS.ByteString)) -> BS.ByteString -> [a]
construct reader str
    | BS.null str = []
    | isSpace (BS8.head str) = construct reader (BS8.tail str)
    | otherwise = let Just (i, other) = reader str in i : construct reader other

getInts :: IO [Int]
getInts = construct BS8.readInt <$> BS.getLine

getIntegers :: IO [Integer]
getIntegers = construct BS8.readInteger <$> BS.getLine

printInts :: [Int] -> IO ()
printInts = putStrLn . unwords . map show

solve' xs _ _ 0 = 0
solve' (x:xs) flipCount oneCount zeroCount
    | num == 1 = 1 + solve' xs (flipCount + 1) nextZero nextOne
    | otherwise = solve' xs flipCount nextOne nextZero
    where num = (x+flipCount) `mod` 2
          nextZero = if num == 0 then zeroCount - 1 else zeroCount
          nextOne = if num == 1 then oneCount - 1 else oneCount

solve xs = solve' xs 0 oneCount zeroCount
    where oneCount = sum xs
          zeroCount = length xs - sum xs

main = do
  [t] <- getInts
  forM_ [1..t] $ \_ -> do
    _ <- getInts
    xs <- BS.getLine <&> (map digitToInt . filter (\x -> x == '0' || x == '1') . BS8.unpack)
    print $ solve xs

{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
#ifndef DEBUG
{-# LANGUAGE Safe #-}
#endif
{-# LANGUAGE Strict #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -O3 -funbox-strict-fields -fvia-C -optc-O3 #-}

import Control.Arrow ((>>>))
import Control.Monad (
    MonadPlus (mplus),
    foldM_,
    forM_,
    guard,
    join,
    replicateM,
    replicateM_,
 )
import qualified Control.Monad as M
import qualified Control.Monad.ST.Strict as ST
import qualified Control.Monad.State.Strict as S
import qualified Control.Monad.Trans.Class as T

import qualified Data.Array as A
import qualified Data.Array.MArray.Safe as MA
import qualified Data.Array.IO.Safe as IOA
import qualified Data.Array.ST.Safe as STA
import qualified Data.Array.Unboxed as UA

import Data.Bits
import qualified Data.ByteString.Char8 as B8
import Data.Char
import Data.Int

import Data.Function (on)
import Data.Functor ((<&>))
import Data.Bifunctor (bimap)
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Maybe as MB

import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.List   as L
import Data.List (
    elemIndices,
    find,
    findIndices,
    intersect,
    isPrefixOf,
    nub,
    sort,
    sortOn,
 )
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Ix as Ix
import qualified Data.Ratio as R

import Control.Monad.Cont (MonadIO (liftIO))
import Data.IORef (modifyIORef, newIORef, readIORef)
import GHC.IO.Handle (hDuplicateTo)
import System.IO (
    IOMode (ReadMode, WriteMode),
    openFile,
    stdin,
    stdout,
    hFlush
 )
import System.Posix.Internals (puts)
import Text.Printf (printf)
import qualified Data.Array.IO.Safe as UOA

#ifdef DEBUG
import Debug.Trace (trace, traceM, traceShowM)
debug = flip trace

tracing t x = trace (t ++ " = " ++ show x) x
debugging x t = tracing t x

tracingM t x = traceM $ t ++ " = " ++ show x

#else

debug x _ = x
trace _ x = x
tracing _ x = x
debugging x _ = x

traceM _ = pure ()
tracingM _ _ = pure ()
#endif

readIntB8 :: B8.ByteString -> Int
readIntB8 = B8.readInt >>> (fst . fromJust)

readIntB8s :: B8.ByteString -> [Int]
readIntB8s = B8.words >>> map (B8.readInt >>> (fst . fromJust))

readIntegerB8 :: B8.ByteString -> Integer
readIntegerB8 = B8.readInteger >>> (fst . fromJust)

readIntegerB8s :: B8.ByteString -> [Integer]
readIntegerB8s = B8.words >>> map (B8.readInteger >>> (fst . fromJust))

modifyArray :: (MA.MArray a e m, MA.Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray arr ix f = do
    value <- MA.readArray arr ix
    MA.writeArray arr ix $ f value

putsYesNo :: Bool -> IO ()
putsYesNo value = do
    let result :: String =
            if value
                then "YES"
                else "NO"
    printf "%s\n" result

{- END OF GENERAL -}

solve :: Int -> String -> Int
solve n str = L.length groupsToInvert
    where
        bitGroups = L.group str
        groupsToInvert = L.dropWhile (\g -> L.head g == '1') . L.dropWhile (\g -> L.head g == '0') $ bitGroups

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        n <- B8.getLine <&> readIntB8
        str <- B8.getLine <&> B8.filter isAlphaNum <&> B8.unpack
        let answer = solve n str
        printf "%d\n" $ answer


You are given $$$n$$$ segments on a number line, numbered from $$$1$$$ to $$$n$$$. The $$$i$$$-th segments covers all integer points from $$$l_i$$$ to $$$r_i$$$ and has a value $$$w_i$$$.You are asked to select a subset of these segments (possibly, all of them). Once the subset is selected, it's possible to travel between two integer points if there exists a selected segment that covers both of them. A subset is good if it's possible to reach point $$$m$$$ starting from point $$$1$$$ in arbitrary number of moves.The cost of the subset is the difference between the maximum and the minimum values of segments in it. Find the minimum cost of a good subset.In every test there exists at least one good subset.

The first line contains two integers $$$n$$$ and $$$m$$$ ($$$1 \le n \le 3 \cdot 10^5$$$; $$$2 \le m \le 10^6$$$) — the number of segments and the number of integer points. Each of the next $$$n$$$ lines contains three integers $$$l_i$$$, $$$r_i$$$ and $$$w_i$$$ ($$$1 \le l_i < r_i \le m$$$; $$$1 \le w_i \le 10^6$$$) — the description of the $$$i$$$-th segment. In every test there exists at least one good subset.

Print a single integer — the minimum cost of a good subset.

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

data STree = Empty | Node !Int !Int !STree !STree

getx :: STree -> Int
getx ~(Node x _ _ _) = x

buildST :: Int -> Int -> STree
buildST l h
    | l + 1 == h = Node 0 0 Empty Empty
    | otherwise  = Node 0 0 (buildST l m) (buildST m h)
    where m = (l + h) `div` 2

updST :: STree -> Int -> Int -> Int -> Int -> Int -> STree
updST ~n@(Node x s ln rn) l h ql qh d
    | h <= ql || qh <= l = n
    | ql <= l && h <= qh = mk (s + d) ln rn
    | otherwise          = mk s (updST ln l m ql qh d) (updST rn m h ql qh d)
    where
        m = (l + h) `div` 2
        mk s ln rn = Node x s ln rn where
            x | s /= 0     = h - l
              | l + 1 == h = 0
              | otherwise  = getx ln + getx rn

data Seg = Seg { getl :: !Int , getr :: !Int , getw :: !Int }

solve :: IO ()
solve = do
    [n, m] <- readInts
    s <- replicateM n readInts
    let sa = listArray (0, n - 1) $ sortOn getw $ map (\[l, r, w] -> Seg l r w) s
        go i j st
            | getx st == m - 1 = getw sj1 - getw si : go (i + 1) j (updST st 1 m (getl si) (getr si) (-1))
            | j < n            = go i (j + 1) (updST st 1 m (getl sj) (getr sj) 1)
            | otherwise        = []
            where si = sa!i
                  sj = sa!j
                  sj1 = sa!(j - 1)
    print $ minimum $ go 0 0 (buildST 1 m)

parseInt = f . C.readInt where f (Just (i, _)) = i
readInts = map parseInt . C.words <$> C.getLine

main :: IO ()
main = solve


You are given two integers $$$a$$$ and $$$b$$$. In one turn, you can do one of the following operations:   Take an integer $$$c$$$ ($$$c > 1$$$ and $$$a$$$ should be divisible by $$$c$$$) and replace $$$a$$$ with $$$\frac{a}{c}$$$;  Take an integer $$$c$$$ ($$$c > 1$$$ and $$$b$$$ should be divisible by $$$c$$$) and replace $$$b$$$ with $$$\frac{b}{c}$$$. Your goal is to make $$$a$$$ equal to $$$b$$$ using exactly $$$k$$$ turns.For example, the numbers $$$a=36$$$ and $$$b=48$$$ can be made equal in $$$4$$$ moves:   $$$c=6$$$, divide $$$b$$$ by $$$c$$$ $$$\Rightarrow$$$ $$$a=36$$$, $$$b=8$$$;  $$$c=2$$$, divide $$$a$$$ by $$$c$$$ $$$\Rightarrow$$$ $$$a=18$$$, $$$b=8$$$;  $$$c=9$$$, divide $$$a$$$ by $$$c$$$ $$$\Rightarrow$$$ $$$a=2$$$, $$$b=8$$$;  $$$c=4$$$, divide $$$b$$$ by $$$c$$$ $$$\Rightarrow$$$ $$$a=2$$$, $$$b=2$$$. For the given numbers $$$a$$$ and $$$b$$$, determine whether it is possible to make them equal using exactly $$$k$$$ turns.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 10^4$$$). Then $$$t$$$ test cases follow. Each test case is contains three integers $$$a$$$, $$$b$$$ and $$$k$$$ ($$$1 \le a, b, k \le 10^9$$$).

For each test case output:    "Yes", if it is possible to make the numbers $$$a$$$ and $$$b$$$ equal in exactly $$$k$$$ turns;  "No" otherwise.  The strings "Yes" and "No" can be output in any case.

import Control.Arrow ((>>>))
import Data.Bool (bool)
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Maybe (fromMaybe)

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

main :: IO ()
main =
  interact $
  lines >>>
  drop 1 >>> map (words >>> map read >>> solve >>> bool "No" "Yes") >>> unlines

type I64 = Integer

solve :: [Int] -> Bool
solve [a, b, k]
  | a == 1 && b == 1 = False
  | k == 1 = a /= b && (a `mod` b == 0 || b `mod` a == 0)
  | otherwise = k <= fac a + fac b

primes :: [Int]
primes = sieve [2 .. 4 * 10 ^ 4]
  where
    sieve [] = []
    sieve (p:xs) = p : sieve (filter ((/= 0) . (`mod` p)) xs)

fac :: Int -> Int
fac n =
  (\(v, acc) -> acc + bool 1 0 (v == 1)) $
  foldl (\(v, acc) p -> f v p acc) (n, 0) primes
  where
    f v p acc
      | v `mod` p /= 0 = (v, acc)
      | otherwise = f (v `div` p) p (acc + 1)

import Control.Monad

main = do t <- read <$> getLine
          replicateM t solve

factorize :: [Int] -> Int -> Int
factorize _ 1 = 0
factorize (d:ds) n
    | d * d > n = 1
    | n `mod` d == 0 = 1 + (factorize (d:ds) (n `div` d))
    | otherwise = factorize (ds) n

primes :: [Int]
primes = 2: 3: sieve (tail primes) [5,7..]
  where
    sieve (p:ps) xs = h ++ sieve ps [x | x <- t, x `rem` p /= 0]
      where (h,~(_:t)) = span (< p*p) xs

primeFactors :: Int -> Int
primeFactors = factorize primes

solve = do arr <- map read . words <$> getLine
           let times = arr !! 2
           let a = arr !! 0
           let b = arr !! 1
           let facta = primeFactors a
           let factb = primeFactors b
           let m = if a == b
                    then 0
                    else if ((a `mod` b) == 0)|| ((b `mod` a) == 0)
                      then 1
                      else 2
           let n = facta + factb
           putStrLn $ ans m n times

ans :: Int -> Int -> Int -> String
ans m n times
  | times == 1 && m == 1 && n >= 1 = "Yes"
  | times /= 1 && m <= times && n >= times = "Yes"
  | otherwise = "No"

--prewritten code: https://github.com/antma/algo
{-# LANGUAGE BangPatterns, FlexibleContexts #-}
{-# Options_GHC -O2 #-}
import Data.ByteString.Builder
import Data.Monoid
import System.IO
import qualified Data.ByteString.Char8 as C
import Data.Time (diffTimeToPicoseconds, utctDayTime, getCurrentTime)
import Data.Char
import Data.Array.Unboxed
import Control.Monad
import Control.Monad.ST
import Data.Array.ST
import Data.Bits
import Data.List(group,sort)

primeArray :: Int -> UArray Int Bool
primeArray n = runSTUArray $ do
  let m = max 1 (shiftR n 1)
      dhm :: Double
      dhm = sqrt $ fromIntegral $ pred n
      hm = ceiling dhm
  a <- newArray (0, m) False :: ST s (STUArray s Int Bool)
  writeArray a 0 True
  forM_ [1 .. pred hm] $ \p -> do
    l <- readArray a p
    unless l $ do
      let k = succ $ 2 * p
          loop j = when (j < m) $ do
                     writeArray a j True
                     loop (j + k)
      loop (2 * p * succ p)
  return a

isprime :: UArray Int Bool -> Int -> Bool
isprime p x = if even x then x == 2 else not (p ! shiftR x 1)

primes :: Int -> [Int]
primes n = 2 : filter ( not . (pa ! ) . (`shiftR` 1)) [3, 5 .. n]
  where
    pa = primeArray n

factors :: [Int] -> Int -> [Int]
factors p n = loop n p []
  where
    loop 1 _ r = r
    loop m l@(x:xs) r
      | x * x > m = m : r
      | mod m x == 0 = loop (div m x) l (x:r)
      | otherwise = loop m xs r

factorization :: [Int] -> Int -> [(Int, Int)]
factorization primes' n = map (\l -> (head l, length l)) $ group $ factors primes' n

divisors :: [Int] -> Int -> [Int]
divisors primes' n = sort $ loop (factorization primes' n) 1 []
  where
    loop [] !m r = m : r
    loop ((!c, !p):xs) m r = snd $ (iterate f (m, r)) !! (p + 1)
      where
        f (!m', r') = (m' * c, loop xs m' r')
ru, ri :: C.ByteString -> Int

ru = C.foldl' (\a c -> a * 10 - 48 + ord c) 0
ri s
  | C.head s == '-' = negate $ ru $ C.tail s
  | otherwise = ru s

p = primes 32000

radd (u1, v1) (u2, v2) = (u1 + u2, v1 + v2)

rng 1 = (0, 0)
rng x = (1, sum $ map snd u)
  where
    u = factorization p x

test' :: Int -> Int -> Int -> Bool
test' a b k
  | k == 1 && a /= b && ((mod a b) == 0 || (mod b a) == 0) = True
  | fst r1 <= k && k <= snd r1 = True
  | g == 1 = False
  | otherwise = (min 2 (fst r2)) <= k && k <= snd r2
  where
    g = gcd a b
    a' = div a g
    b' = div b g
    r1 = radd (rng a') (rng b')
    rg = rng g
    rg2 = radd rg rg
    r2 = radd rg2 r1
    --r = if g > 1 then radd

ans True = byteString $ C.pack "YES"
ans False = byteString $ C.pack "NO"

nl = char7 '\n'
test :: Builder -> Int -> [Int] -> Builder
test buf 0 _ = buf
test buf nt (a:b:k:xs) = test (buf <> ans (test' a b k) <> nl) (pred nt) xs

solve :: [Int] -> Builder
solve (nt:xs) = test mempty nt xs

main :: IO ()
main = hPutBuilder stdout . solve . map ri . C.words =<< C.getContents

import Control.Arrow ((>>>))
import Data.Bool (bool)
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Maybe (fromMaybe)

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

main :: IO ()
main =
  interact $
  lines >>>
  drop 1 >>> map (words >>> map read >>> solve >>> bool "No" "Yes") >>> unlines

type I64 = Integer

solve :: [Int] -> Bool
solve [a, b, k]
  | 2 <= k && k <= fac a + fac b = True
  | k > fac a + fac b = False
  | otherwise = a /= b

mx :: Int
mx = 4 * 10 ^ 4

primes :: [Int]
primes = sieve [2 .. mx]
  where
    sieve [] = []
    sieve (p:xs) = p : sieve (filter ((/= 0) . (`mod` p)) xs)

fac :: Int -> Int
fac n =
  (\(v, acc) -> acc + bool 1 0 (v == 1)) $
  foldl (\(v, acc) p -> f v p acc) (n, 0) primes
  where
    f v p acc
      | v `mod` p /= 0 = (v, acc)
      | otherwise = f (v `div` p) p (acc + 1)

import Control.Arrow ((>>>))
import Data.Bool (bool)
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Maybe (fromMaybe)

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

main :: IO ()
main =
  interact $
  lines >>>
  drop 1 >>> map (words >>> map read >>> solve >>> bool "No" "Yes") >>> unlines

type I64 = Integer

solve :: [Int] -> Bool
solve [a, b, k]
  | k == 1 = a `mod` b == 0 || b `mod` a == 0
  | otherwise = k <= fac a + fac b

mx :: Int
mx = 4 * 10 ^ 4

primes :: [Int]
primes = sieve [2 .. mx]
  where
    sieve [] = []
    sieve (p:xs) = p : sieve (filter ((/= 0) . (`mod` p)) xs)

fac :: Int -> Int
fac n =
  (\(v, acc) -> acc + bool 1 0 (v == 1)) $
  foldl (\(v, acc) p -> f v p acc) (n, 0) primes
  where
    f v p acc
      | v `mod` p /= 0 = (v, acc)
      | otherwise = f (v `div` p) p (acc + 1)

import Control.Arrow ((>>>))
import Data.Bool (bool)
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Maybe (fromMaybe)

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

main :: IO ()
main =
  interact $
  lines >>>
  drop 1 >>> map (words >>> map read >>> solve >>> bool "No" "Yes") >>> unlines

type I64 = Integer

solve :: [Int] -> Bool
solve [a, b, k]
  | a == b = k == 0
  | k == 1 = a `mod` b == 0 || b `mod` a == 0
  | otherwise = k <= fac a + fac b

mx :: Int
mx = 4 * 10 ^ 4

primes :: [Int]
primes = sieve [2 .. mx]
  where
    sieve [] = []
    sieve (p:xs) = p : sieve (filter ((/= 0) . (`mod` p)) xs)

fac :: Int -> Int
fac n = (\(v, acc) -> acc + bool 1 0 (v == 1)) $ foldl f (n, 0) primes
  where
    f (v, acc) p
      | v `mod` p /= 0 = (v, acc)
      | otherwise =
        let (v', acc') = f (v `div` p, acc) p
         in (v', acc' + 1)

import Control.Arrow ((>>>))
import Data.Bool (bool)
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Maybe (fromMaybe)

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

main :: IO ()
main =
  interact $
  lines >>>
  drop 1 >>> map (words >>> map read >>> solve >>> bool "No" "Yes") >>> unlines

type I64 = Integer

solve :: [Int] -> Bool
solve [a, b, k]
  | a == b = k == 0
  | k == 1 = a `mod` b == 0 || b `mod` a == 0
  | otherwise = k <= fac a + fac b

mx :: Int
mx = 4 * 10 ^ 4

primes :: [Int]
primes = sieve [2 .. mx]
  where
    sieve [] = []
    sieve (p:xs) = p : sieve (filter ((/= 0) . (`mod` p)) xs)

fac :: Int -> Int
fac n = snd $ foldl f (n, 0) primes
  where
    f (v, acc) p
      | v `mod` p /= 0 = (v, acc)
      | otherwise =
        let (v', acc') = f (v `div` p, acc) p
         in (v', acc' + 1)

import Control.Monad

main = do t <- read <$> getLine
          replicateM t solve

factorize :: Int -> Int -> [Int]
factorize _ 1 = []
factorize d n
    | d * d > n = [n]
    | n `mod` d == 0 = d : factorize d (n `div` d)
    | otherwise = factorize (d + 1) n

primeFactors :: Int -> [Int]
primeFactors = factorize 2

solve = do arr <- map read . words <$> getLine
           let times = arr !! 2
           let a = arr !! 0
           let b = arr !! 1
           let facta = length $ primeFactors a
           let factb = length $ primeFactors b
           putStrLn $ ans a b facta factb times

ans :: Int -> Int -> Int -> Int -> Int -> String
ans a b facta factb times
  | (a == 1) && (factb >= times) = "Yes"
  | (b == 1) && (facta >= times) = "Yes"
  | (a == 1) || (b == 1) = "No"
  | (times == 1) && (a == b) = "No"
  | (facta + factb) >= times = "Yes"
  | (times == 1) && ((a `mod` b) == 0) = "Yes"
  | (times == 1) && ((b `mod` a) == 0) = "Yes"
  | otherwise = "No"

--prewritten code: https://github.com/antma/algo
{-# LANGUAGE BangPatterns, FlexibleContexts #-}
{-# Options_GHC -O2 #-}
import Data.ByteString.Builder
import Data.Monoid
import System.IO
import qualified Data.ByteString.Char8 as C
import Data.Time (diffTimeToPicoseconds, utctDayTime, getCurrentTime)
import Data.Char
import Data.Array.Unboxed
import Control.Monad
import Control.Monad.ST
import Data.Array.ST
import Data.Bits
import Data.List(group,sort)

primeArray :: Int -> UArray Int Bool
primeArray n = runSTUArray $ do
  let m = max 1 (shiftR n 1)
      dhm :: Double
      dhm = sqrt $ fromIntegral $ pred n
      hm = ceiling dhm
  a <- newArray (0, m) False :: ST s (STUArray s Int Bool)
  writeArray a 0 True
  forM_ [1 .. pred hm] $ \p -> do
    l <- readArray a p
    unless l $ do
      let k = succ $ 2 * p
          loop j = when (j < m) $ do
                     writeArray a j True
                     loop (j + k)
      loop (2 * p * succ p)
  return a

isprime :: UArray Int Bool -> Int -> Bool
isprime p x = if even x then x == 2 else not (p ! shiftR x 1)

primes :: Int -> [Int]
primes n = 2 : filter ( not . (pa ! ) . (`shiftR` 1)) [3, 5 .. n]
  where
    pa = primeArray n

factors :: [Int] -> Int -> [Int]
factors p n = loop n p []
  where
    loop 1 _ r = r
    loop m l@(x:xs) r
      | x * x > m = m : r
      | mod m x == 0 = loop (div m x) l (x:r)
      | otherwise = loop m xs r

factorization :: [Int] -> Int -> [(Int, Int)]
factorization primes' n = map (\l -> (head l, length l)) $ group $ factors primes' n

divisors :: [Int] -> Int -> [Int]
divisors primes' n = sort $ loop (factorization primes' n) 1 []
  where
    loop [] !m r = m : r
    loop ((!c, !p):xs) m r = snd $ (iterate f (m, r)) !! (p + 1)
      where
        f (!m', r') = (m' * c, loop xs m' r')
ru, ri :: C.ByteString -> Int

ru = C.foldl' (\a c -> a * 10 - 48 + ord c) 0
ri s
  | C.head s == '-' = negate $ ru $ C.tail s
  | otherwise = ru s

p = primes 32000

radd (u1, v1) (u2, v2) = (u1 + u2, v1 + v2)

rng 1 = (0, 0)
rng x = (1, sum $ map snd u)
  where
    u = factorization p x

test' :: Int -> Int -> Int -> Bool
test' a b k
  | fst r1 <= k && k <= snd r1 = True
  | g == 1 = False
  | otherwise = fst r2 <= k && k <= snd r2
  where
    g = gcd a b
    a' = div a g
    b' = div b g
    r1 = radd (rng a') (rng b')
    rg = rng g
    rg2 = radd rg rg
    r2 = radd rg2 r1
    --r = if g > 1 then radd

ans True = byteString $ C.pack "YES"
ans False = byteString $ C.pack "NO"

nl = char7 '\n'
test :: Builder -> Int -> [Int] -> Builder
test buf 0 _ = buf
test buf nt (a:b:k:xs) = test (buf <> ans (test' a b k) <> nl) (pred nt) xs

solve :: [Int] -> Builder
solve (nt:xs) = test mempty nt xs

main :: IO ()
main = hPutBuilder stdout . solve . map ri . C.words =<< C.getContents


The statement of this problem is the same as the statement of problem C2. The only difference is that, in problem C1, $$$n$$$ is always even, and in C2, $$$n$$$ is always odd.You are given a regular polygon with $$$2 \cdot n$$$ vertices (it's convex and has equal sides and equal angles) and all its sides have length $$$1$$$. Let's name it as $$$2n$$$-gon.Your task is to find the square of the minimum size such that you can embed $$$2n$$$-gon in the square. Embedding $$$2n$$$-gon in the square means that you need to place $$$2n$$$-gon in the square in such way that each point which lies inside or on a border of $$$2n$$$-gon should also lie inside or on a border of the square.You can rotate $$$2n$$$-gon and/or the square.

The first line contains a single integer $$$T$$$ ($$$1 \le T \le 200$$$) — the number of test cases. Next $$$T$$$ lines contain descriptions of test cases — one per line. Each line contains single even integer $$$n$$$ ($$$2 \le n \le 200$$$). Don't forget you need to embed $$$2n$$$-gon, not an $$$n$$$-gon.

Print $$$T$$$ real numbers — one per test case. For each test case, print the minimum length of a side of the square $$$2n$$$-gon can be embedded in. Your answer will be considered correct if its absolute or relative error doesn't exceed $$$10^{-6}$$$.

main = interact $ g . map read . tail . words

f n = 1/(tan (pi/(2*n)))

g xs = unlines (map show (map f xs))

import Data.List

solve :: Integer -> Double
solve n = 1/(tan (pi/(2* (fromIntegral n))))

main = interact $
          (intercalate "\n")
          . (map (show . solve . read))
          . (drop 1)
          . words

import Control.Monad
import Data.List

main = do
    t <- readLn :: IO Int
    replicateM_ t routine

routine = do
    n <- readLn :: IO Int
    print $ solve n

solve :: Int -> Double
solve a
    -- odd side
    | mod a 2 == 1 = 2*side
    -- even height
    | otherwise = 2*height
  where
      height =  (side ^ 2) * sin_given
      side = sin_theta / sin_given
      sin_given = sin (pi / fromIntegral a)
      sin_theta = sin (pi * (0.5*(1 - 1/fromIntegral a)))

import qualified Data.List as L
import qualified Data.Map as M
import Data.Map (Map)
import qualified Data.Set as S
import Data.Set (Set)
import qualified Data.IntSet as IS
import Data.IntSet (IntSet)
import qualified Data.IntMap as IM
import Data.IntMap (IntMap)
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)

type Long = Int

solve :: Double -> Double
solve n = 1 / tan (pi / (2* n))

testCases :: Int -> IO ()
testCases 0 = return ()
testCases t = do
    (n:_) <- readWords
    print $ solve n
    testCases (t-1)

main :: IO ()
main = do
    (t:_) <- readWords
    testCases t

readWords :: (Read a) => IO [a]
readWords = map read . words <$> getLine


You are given a binary string $$$s$$$ consisting of $$$n$$$ zeros and ones.Your task is to divide the given string into the minimum number of subsequences in such a way that each character of the string belongs to exactly one subsequence and each subsequence looks like "010101 ..." or "101010 ..." (i.e. the subsequence should not contain two adjacent zeros or ones).Recall that a subsequence is a sequence that can be derived from the given sequence by deleting zero or more elements without changing the order of the remaining elements. For example, subsequences of "1011101" are "0", "1", "11111", "0111", "101", "1001", but not "000", "101010" and "11100".You have to answer $$$t$$$ independent test cases.

The first line of the input contains one integer $$$t$$$ ($$$1 \le t \le 2 \cdot 10^4$$$) — the number of test cases. Then $$$t$$$ test cases follow. The first line of the test case contains one integer $$$n$$$ ($$$1 \le n \le 2 \cdot 10^5$$$) — the length of $$$s$$$. The second line of the test case contains $$$n$$$ characters '0' and '1' — the string $$$s$$$. 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: in the first line print one integer $$$k$$$ ($$$1 \le k \le n$$$) — the minimum number of subsequences you can divide the string $$$s$$$ to. In the second line print $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i \le k$$$), where $$$a_i$$$ is the number of subsequence the $$$i$$$-th character of $$$s$$$ belongs to. If there are several answers, you can print any.

{-# LANGUAGE Safe #-}

import safe Control.Arrow ((>>>))

main :: IO ()
main =
  interact $
    lines >>> drop 1
      >>> process
      >>> map (map show >>> unwords)
      >>> unlines

process :: [String] -> [[Int]]
process [] = []
process (_ : xs : rest) = let (k, ss) = solve xs in [k] : ss : process rest

solve :: String -> (Int, [Int])
solve = (\(_, _, ps, k) -> (k, ps)) . foldr pick ([], [], [], 0)
  where
    pick :: Char -> ([Int], [Int], [Int], Int) -> ([Int], [Int], [Int], Int)
    pick '0' (xs, [], ps, k) = ((k + 1) : xs, [], (k + 1) : ps, k + 1)
    pick '0' (xs, y : ys, ps, k) = (y : xs, ys, y : ps, k)
    pick '1' ([], ys, ps, k) = ([], (k + 1) : ys, (k + 1) : ps, k + 1)
    pick '1' (x : xs, ys, ps, k) = (xs, x : ys, x : ps, k)

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

main = getLine >>= flip replicateM_ test . read

test = do
  getLine
  s <- map (== '1') <$> getLine
  let a = solve 1 [] [] s
  print $ maximum a
  putStrLn $ unwords $ map show a

solve next (z : zs) os (False : s) = z : solve next zs (z : os) s
solve next [] os (False : s) = next : solve (succ next) [] (next : os) s
solve next zs (o : os) (_ : s) = o : solve next (o : zs) os s
solve next zs [] (_ : s) = next : solve (succ next) (next : zs) [] s
solve _ _ _ _ = []

import Control.Monad

rec :: Int -> [Int] -> [Int] -> [Bool] -> [Int]
rec next (z : zs) os (False : s) = z : rec next zs (z : os) s
rec next [] os (False : s) = next : rec (succ next) [] (next : os) s
rec next zs (o : os) (_ : s) = o : rec next (o : zs) os s
rec next zs [] (_ : s) = next : rec (succ next) (next : zs) [] s
rec _ _ _ _ = []

solve :: IO ()
solve = do
  getLine
  s <- map (== '1') <$> getLine
  let a = rec 1 [] [] s
  print $ maximum a
  putStrLn $ unwords $ map show a

main :: IO ()
main = do
  getLine >>= flip replicateM_ solve . read

import Control.Monad -- for replicateM_
import Data.List -- for sort

{-
 -
 - meet 0 and
 - 1. ones is empty
 -      add it to zeros.
 - 2. ones isn't empty
 -      pop ones, and add it to zeros.
 - meet 1 and
 - 1. zeros is empty
 -      add it to ones.
 - 2. zeros isn't empty
 -      pop zeros, and add it to ones.
 -}
solve :: Int -> [Bool] -> [Int] -> [Int] -> [Int]
solve now_id (False:xs) zeros [] = now_id : solve (now_id+1) xs (now_id:zeros) []
solve now_id (False:xs) zeros (o:ones) = o : solve now_id  xs (o:zeros) ones
solve now_id (True:xs) [] ones = now_id : solve (now_id+1) xs [] (now_id:ones)
solve now_id (True:xs) (z:zeros) ones = z : solve now_id  xs zeros (z:ones)
solve now_id _ _ _ = []

deal :: IO()
deal = do
    getLine
    a <- map (== '1')  <$> getLine
    let answer = solve 1 a [] []
    print $ maximum answer
    putStrLn $ unwords $ map show answer

main :: IO()
main = getLine >>= flip replicateM_ deal . read

{-# LANGUAGE BangPatterns #-}

import Data.List (unfoldr)

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Lazy as R
import Data.Word (Word8)

type ByteString = P.ByteString

zeroChar :: Word8
zeroChar = R.head $ P.singleton '0'

oneChar :: Word8
oneChar = R.head $ P.singleton '1'

parseCases :: ByteString -> [ByteString]
parseCases inp = go (tail $ P.lines inp)  where
  go [] = []
  go (_nstr : s : excess) = s : go excess
  go _ = error "malformed input"

type State = (Int, Int, Int, ByteString)
step :: State -> Maybe (Int, State)
-- Idea:  pos - zeros  is the number of subsequences so far which end in zero.
--        ones - pos   is the number of subsequences so far which end in one.
-- new sequences with '0' are allocated non-negative indices,
-- new sequences with '1' are allocated     negative indices.
step (!pos, !zeros, !ones, !str) = case  R.uncons str  of
  Nothing -> Nothing
  Just (c, xs)
    | c == zeroChar -> Just (pos,   (pos+1, zeros, max ones (pos+1), xs))
    | c == oneChar  -> Just (pos-1, (pos-1, min zeros (pos-1), ones, xs))
  _ -> Nothing -- error "malformed input"

-- hopefully String is fast enough
solveCase :: ByteString -> String
solveCase inp = let
  rawAnsSeq = unfoldr step (0, 0, 0, inp)
  low = minimum rawAnsSeq
  top = maximum rawAnsSeq
  subseqCount = top + 1 - low
  as = map (1 - low +) rawAnsSeq
  in  unlines [show subseqCount, unwords (map show as)]

main :: IO ()
main = P.getContents >>= (putStr . concatMap solveCase . parseCases)


There are $$$n$$$ pieces of tangerine peel, the $$$i$$$-th of them has size $$$a_i$$$. In one step it is possible to divide one piece of size $$$x$$$ into two pieces of positive integer sizes $$$y$$$ and $$$z$$$ so that $$$y + z = x$$$.You want that for each pair of pieces, their sizes differ strictly less than twice. In other words, there should not be two pieces of size $$$x$$$ and $$$y$$$, such that $$$2x \le y$$$. What is the minimum possible number of steps needed to satisfy the condition?

The first line of the input contains a single integer $$$t$$$ ($$$1 \le t \le 100$$$) — the number of test cases. The description of test cases follows. The first line of each test case contains the integer $$$n$$$ ($$$1 \le n \le 100$$$). Then one line follows, containing $$$n$$$ integers $$$a_1 \le a_2 \le \ldots \le a_n$$$ ($$$1 \le a_i \le 10^7$$$).

For each test case, output a single line containing the minimum number of steps.

NoteIn the first test case, we initially have a piece of size $$$1$$$, so all final pieces must have size $$$1$$$. The total number of steps is: $$$0 + 1 + 2 + 3 + 4 = 10$$$.In the second test case, we have just one piece, so we don't need to do anything, and the answer is $$$0$$$ steps.In the third test case, one of the possible cut options is: $$$600,\ 900,\ (600 | 700),\ (1000 | 1000),\ (1000 | 1000 | 550)$$$. You can see this option in the picture below. The maximum piece has size $$$1000$$$, and it is less than $$$2$$$ times bigger than the minimum piece of size $$$550$$$. $$$4$$$ steps are done. We can show that it is the minimum possible number of steps.

import Control.Monad

toShow [] = ""
toShow (x:xs) = show x ++ " " ++ toShow xs

main :: IO ()
main = do
    ts <- getLine
    replicateM (read ts::Int) $ do
        input <- getLine
        let n = read  input ::Int
        input <- getLine
        let a = map read . words $ input ::[Int]
        let mi = minimum a

        putStrLn.show.sum .map ((`div` (2*mi-1)).subtract 1) $ a
    return ()

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

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

{-# options_ghc -O3                              #-}

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

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

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

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

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

solve xs = sum . map cntSplit $ xs
  where
    m = minimum xs
    mx = m*2 - 1
    cntSplit x = ((x+mx-1) `div` mx) - 1

import Data.Char

second (x:y:xs) = y : second xs;
second _ = []

pieces n k
  | mod k (2*n-1) == 0 = div k (2*n-1)
  | otherwise = div k (2*n-1) +1

moves n k = pieces n k - 1
solve xs = sum $ map (moves n) ks where
  n = head xs
  ks = tail xs

main = do
  rawInput <- getContents
  let input = (second . tail) $ lines rawInput
  let ls = map ((map read) . words) input :: [[Int]]
  let output = map solve ls
  putStr (unlines $ map show output)

--
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- {-# LANGUAGE Strict #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -O3 -funbox-strict-fields -fvia-C -optc-O3 #-}

import Control.Arrow ((>>>))
import Control.Monad (
    MonadPlus (mplus),
    foldM_,
    forM_,
    guard,
    join,
    replicateM,
    replicateM_,
 )
import qualified Control.Monad as M
import qualified Control.Monad.ST.Strict as ST
import qualified Control.Monad.State.Strict as S
import qualified Control.Monad.Trans.Class as T

import qualified Data.Array as A
import qualified Data.Array.MArray.Safe as MA
import qualified Data.Array.IO.Safe as IOA
import qualified Data.Array.ST.Safe as STA
import qualified Data.Array.Unboxed as UA

import Data.Bits
import qualified Data.ByteString.Char8 as B8
import Data.Char
import Data.Int

import Data.Function (on)
import Data.Functor ((<&>))
import Data.Bifunctor (bimap)
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Maybe as MB

import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.List   as L
import Data.List (
    elemIndices,
    find,
    findIndices,
    intersect,
    isPrefixOf,
    nub,
    sort,
    sortOn,
 )
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Ix as Ix
import qualified Data.Ratio as R

import Control.Monad.Cont (MonadIO (liftIO))
import Data.IORef (modifyIORef, newIORef, readIORef)
import GHC.IO.Handle (hDuplicateTo)
import System.IO (
    IOMode (ReadMode, WriteMode),
    openFile,
    stdin,
    stdout,
    hFlush
 )
import System.Posix.Internals (puts)
import Text.Printf (printf)
import qualified Data.Array.IO.Safe as UOA

-- import Debug.Trace (trace, traceM, traceShowM)
-- debug = flip trace
--
-- tracing t x = trace (t ++ " = " ++ show x) x
-- debugging x t = tracing t x
--
-- debug x t = x
-- trace t x = x
-- tracing t x = x
-- debugging x t = x

readIntB8 :: B8.ByteString -> Int
readIntB8 = B8.readInt >>> (fst . fromJust)

readIntB8s :: B8.ByteString -> [Int]
readIntB8s = B8.words >>> map (B8.readInt >>> (fst . fromJust))

readIntegerB8 :: B8.ByteString -> Integer
readIntegerB8 = B8.readInteger >>> (fst . fromJust)

readIntegerB8s :: B8.ByteString -> [Integer]
readIntegerB8s = B8.words >>> map (B8.readInteger >>> (fst . fromJust))

modifyArray :: (MA.MArray a e m, MA.Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray arr ix f = do
    value <- MA.readArray arr ix
    MA.writeArray arr ix $ f value

putsYesNo :: Bool -> IO ()
putsYesNo value = do
    let result :: String =
            if value
                then "YES"
                else "NO"
    printf "%s\n" result

{- END OF GENERAL -}

solve :: Int -> [Int] -> Int
solve n as = sum steps
    where
        minA = minimum as
        steps = map stepsFor as
        stepsFor x = (x + d - 1) `div` d - 1
            where d = 2 * minA - 1

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        n <- B8.getLine <&> readIntB8
        as <- B8.getLine <&> readIntB8s
        let answer = solve n as
        printf "%d\n" answer

import Control.Monad (replicateM_)
main = read <$> getLine >>= flip replicateM_ scase
scase = read <$> getLine >>=
        \n -> map read . words <$> getLine >>=
        print . minSteps n

minSteps :: Int -> [Int] -> Int
minSteps n (a:as) = foldl (\acc e -> acc + minStep a e) 0 as

minStep :: Int -> Int -> Int
minStep x y = let f = -1+div y (2*x-1) in
                if f < 0
                then 0
                else f + (if mod y (2*x-1) > 0 then 1 else 0)

import Control.Monad

toShow [] = ""
toShow (x:xs) = show x ++ " " ++ toShow xs

main :: IO ()
main = do
    ts <- getLine
    replicateM (read ts::Int) $ do
        input <- getLine
        let n = read  input ::Int
        input <- getLine
        let a = map read . words $ input ::[Int]
        let mi = minimum a

        putStrLn.show.sum .map (if mi==1 then subtract 1 else  (`div` (2*mi-1))) $ a
    return ()


There is an integer $$$n$$$ without zeros in its decimal representation. Alice and Bob are playing a game with this integer. Alice starts first. They play the game in turns.On her turn, Alice must swap any two digits of the integer that are on different positions. Bob on his turn always removes the last digit of the integer. The game ends when there is only one digit left.You have to find the smallest integer Alice can get in the end, if she plays optimally.

The input consists of multiple test cases. The first line contains a single integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of test cases. Description of the test cases follows. The first and the only line of each test case contains the integer $$$n$$$ ($$$10 \le n \le 10^9$$$) — the integer for the game. $$$n$$$ does not have zeros in its decimal representation.

For each test case output a single integer — the smallest integer Alice can get in the end of the game.

NoteIn the first test case Alice has to swap $$$1$$$ and $$$2$$$. After that Bob removes the last digit, $$$1$$$, so the answer is $$$2$$$.In the second test case Alice can swap $$$3$$$ and $$$1$$$: $$$312$$$. After that Bob deletes the last digit: $$$31$$$. Then Alice swaps $$$3$$$ and $$$1$$$: $$$13$$$ and Bob deletes $$$3$$$, so the answer is $$$1$$$.

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

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

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

main :: IO ()
main = do
  [caseNum] <- getInts
  output <- fmap mconcat $ forM [1..caseNum] $ \_ -> do
    s <- filter (not . isSpace) . C.unpack <$> C.getLine
    return $ char7 (if length s == 2 then s !! 1 else minimum s) <> char7 '\n'
  hPutBuilder stdout output

-- https://codeforces.com/contest/1679/problem/D
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TupleSections #-}

import Control.Arrow ((>>>))
import Control.Monad (
    MonadPlus (mplus),
    foldM_,
    forM_,
    guard,
    join,
    replicateM,
    replicateM_,
 )
import qualified Control.Monad.ST.Strict as ST
import qualified Control.Monad.State.Strict as S

import qualified Data.Array as A
import qualified Data.Array.MArray.Safe as MA
import qualified Data.Array.ST.Safe as STA
import qualified Data.Array.Unboxed as UA

import Data.Bits
import qualified Data.ByteString.Char8 as B8
import Data.Char
import Data.Int

import Data.Function (on)
import Data.Functor ((<&>))
import Data.Bifunctor (bimap)
import Data.Maybe (fromJust, fromMaybe, isJust)

import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.List   as L
import Data.List (
    elemIndices,
    find,
    findIndices,
    intersect,
    isPrefixOf,
    nub,
    sort,
    sortOn,
 )
import qualified Data.Map as M
import qualified Data.Set as S

import Control.Monad.Cont (MonadIO (liftIO))
import Data.IORef (modifyIORef, newIORef, readIORef)
import GHC.IO.Handle (hDuplicateTo)
import System.IO (
    IOMode (ReadMode, WriteMode),
    openFile,
    stdin,
    stdout,
 )
import System.Posix.Internals (puts)
import Text.Printf (printf)

-- import Debug.Trace (trace, traceM, traceShowM)
-- debug = flip trace

readIntB8 :: B8.ByteString -> Int
readIntB8 = B8.readInt >>> (fst . fromJust)

readIntB8s :: B8.ByteString -> [Int]
readIntB8s = B8.words >>> map (B8.readInt >>> (fst . fromJust))

readIntegerB8 :: B8.ByteString -> Integer
readIntegerB8 = B8.readInteger >>> (fst . fromJust)

readIntegerB8s :: B8.ByteString -> [Integer]
readIntegerB8s = B8.words >>> map (B8.readInteger >>> (fst . fromJust))

modifyArray :: (MA.MArray a e m, MA.Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray arr ix f = do
    value <- MA.readArray arr ix
    MA.writeArray arr ix $ f value

putsYesNo :: Bool -> IO ()
putsYesNo value = do
    let result :: String =
            if value
                then "Yes"
                else "No"
    printf "%s\n" result

{- END OF GENERAL -}

solve :: Int -> Int
solve n = solve' digits
    where
        digits = map (\c -> ord c - ord '0') $ show n
        solve' = \case
            [a] -> a
            [a, b] -> b
            ds -> foldr1 min ds

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        a <- B8.getLine <&> readIntB8
        let answer = solve a
        printf "%d\n" answer

import Data.Char

solve :: String -> Char
solve number = if length number == 2
               then number !! 1
               else chr (minimum (map ord number))

mainLoop 0 = return ()
mainLoop t = do number <- getLine
                putStrLn [solve number]
                mainLoop (t - 1)

main = do t <- (readLn :: IO Int)
          mainLoop t

main :: IO ()
main = do
	n <- getLine
	let number = read n :: Int
	solve number number
	return ()

solve :: Int -> Int -> IO ()
solve number 0 = return ()
solve number current = 	do
				line <- getLine
				if length line < 3
					then do
						putStrLn  $ [(last line)]
						solve number (current - 1)
				    else do
						putStrLn  $ [(foldr min '9' line)]
						solve number (current - 1)

module Main (main)
where

import Data.List
import Data.Char

main :: IO ()
main = intercalate "\n" <$> map show <$> map solve <$> map readInts <$> (read <$> getLine >>= readNLines) >>= putStrLn

readNLines :: Int -> IO [String]
readNLines n = sequence $ replicate n getLine

readInts :: String -> [Int]
readInts s = foldr (\x acc -> (ord x - 48):acc) [] s

-- [Int] at least two digits
solve :: [Int] -> Int
solve [a, b] = b
solve xs = minimum xs

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

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

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

main :: IO ()
main = do
  [caseNum] <- getInts
  output <- fmap mconcat $ forM [1..caseNum] $ \_ -> do
    s <- C.unpack <$> C.getLine
    return $ char7 (if length s == 2 then s !! 1 else minimum s) <> char7 '\n'
  hPutBuilder stdout output