An arithmetic progression is such a non-empty sequence of numbers where the difference between any two successive numbers is constant. This constant number is called common difference. For example, the sequence 3, 7, 11, 15 is an arithmetic progression. The definition implies that any sequences whose length equals 1 or 2 are arithmetic and all sequences whose length equals 0 are non-arithmetic.You are given a sequence of different integers a1, a2, ..., an. You should either split it into two arithmetic progressions or find out that the operation is impossible to perform. Splitting assigns each member of the given sequence to one of two progressions, but the relative order of numbers does not change. Splitting is an inverse operation to merging.

The first line contains a positive integer n (2 ≤ n ≤ 30000), n is the length of the given sequence. The second line contains elements of the given sequence a1, a2, ..., an ( - 108 ≤ ai ≤ 108). The elements of the progression are different integers.

Print the required arithmetic progressions, one per line. The progressions can be positioned in any order. Each progression should contain at least one number. If there's no solution, then print "No solution" (without the quotes)in the only line of the input file. If there are several solutions, print any of them.

NoteIn the second sample another solution is also possible (number three can be assigned to the second progression): 1, 2 and 3, -2, -7.

{-# 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.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.Sequence (Seq, (<|), (|>), (><), ViewL(..), ViewR(..))
import qualified Data.Sequence as Seq
import qualified Data.Foldable as F
import Data.Graph

import Debug.Trace

parseInput = do
    n <- readInt
    a <- replicateM n readInt
    return (n, a)
  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 = BS.putStr . myPrint =<< solve . evalState parseInput <$> BS.getContents

myPrint Nothing      = BS.pack "No solution"
myPrint (Just (x,y)) = BS.unlines [ BS.unwords (map (BS.pack.show) x)
                                  , BS.unwords (map (BS.pack.show) y)
                                  ]

check xs
    | length xs <= 2 = True
    | otherwise      = all (==d) ds
  where
    (d:ds) = zipWith (-) (tail xs) xs

solveCase a a0 a1
    | null lst2        = Nothing
    | not (check lst2) = Nothing
    | otherwise        = Just (lst1, lst2)
  where
    n = length a
    mapping = IntMap.fromList $ zip a [1..n]
    arr = listArray (1, n) a :: UArray Int Int

    index1' = map (mapping IntMap.!) $ takeWhile (`IntMap.member` mapping) [a0,a1..]

    ((x,y) : pairs) = zip index1' (tail index1')
    index1 = x : y : map snd (takeWhile (\(x', y') -> compare x' y' == compare x y) pairs)

    set = IntSet.fromList index1

    index2 = filter (`IntSet.notMember` set) [1..n]

    lst1 = map (arr!) (IntSet.toList set)
    lst2 = map (arr!) index2

solve (n, a)
    | n == 2    = Just ([a !! 0], [a !! 1])
    | otherwise = msum answer
  where
    h0 = a !! 0
    h1 = a !! 1
    h2 = a !! 2
    t0 = a !! (n - 1)
    t1 = a !! (n - 2)
    t2 = a !! (n - 3)
    answer = [ solveCase a h0 h1
             , solveCase a h0 h2
             , solveCase a h1 h2
             , solveCase a t0 t1
             , solveCase a t0 t2
             , solveCase a t1 t2
             ]

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

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

{-# 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.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.Sequence (Seq, (<|), (|>), (><), ViewL(..), ViewR(..))
import qualified Data.Sequence as Seq
import qualified Data.Foldable as F
import Data.Graph

import Debug.Trace

parseInput = do
    n <- readInt
    a <- replicateM n readInt
    return (n, a)
  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 = BS.putStr . myPrint =<< solve . evalState parseInput <$> BS.getContents

myPrint Nothing      = BS.pack "No solution"
myPrint (Just (x,y)) = BS.unlines [ BS.unwords (map (BS.pack.show) x)
                                  , BS.unwords (map (BS.pack.show) y)
                                  ]

check xs
    | length xs <= 2 = True
    | otherwise      = all (==d) ds
  where
    (d:ds) = zipWith (-) (tail xs) xs

solveCase a a0 a1
    | not (check lst2) = Nothing
    | otherwise        = Just (lst1, lst2)
  where
    n = length a
    mapping = IntMap.fromList $ zip a [1..n]
    arr = listArray (1, n) a :: UArray Int Int

    index1' = map (mapping IntMap.!) $ takeWhile (`IntMap.member` mapping) [a0,a1..]

    ((x,y) : pairs) = zip index1' (tail index1')
    index1 = x : y : map snd (takeWhile (\(x', y') -> compare x' y' == compare x y) pairs)

    set = IntSet.fromList index1

    index2 = filter (`IntSet.notMember` set) [1..n]

    lst1 = map (arr!) (IntSet.toList set)
    lst2 = map (arr!) index2

solve (n, a)
    | n == 2    = Just ([a !! 0], [a !! 1])
    | otherwise = msum answer
  where
    h0 = a !! 0
    h1 = a !! 1
    h2 = a !! 2
    t0 = a !! (n - 1)
    t1 = a !! (n - 2)
    t2 = a !! (n - 3)
    answer = [ solveCase a h0 h1
             , solveCase a h0 h2
             , solveCase a h1 h2
             , solveCase a t0 t1
             , solveCase a t0 t2
             , solveCase a t1 t2
             ]

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

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


At the children's day, the child came to Picks's house, and messed his house up. Picks was angry at him. A lot of important things were lost, in particular the favorite set of Picks.Fortunately, Picks remembers something about his set S:  its elements were distinct integers from 1 to limit;  the value of  was equal to sum; here lowbit(x) equals 2k where k is the position of the first one in the binary representation of x. For example, lowbit(100102) = 102, lowbit(100012) = 12, lowbit(100002) = 100002 (binary representation). Can you help Picks and find any set S, that satisfies all the above conditions?

The first line contains two integers: sum, limit (1 ≤ sum, limit ≤ 105).

In the first line print an integer n (1 ≤ n ≤ 105), denoting the size of S. Then print the elements of set S in any order. If there are multiple answers, print any of them. If it's impossible to find a suitable set, print -1.

NoteIn sample test 1: lowbit(4) = 4, lowbit(5) = 1, 4 + 1 = 5.In sample test 2: lowbit(1) = 1, lowbit(2) = 2, lowbit(3) = 1, 1 + 2 + 1 = 4.

{-# LANGUAGE Arrows #-}

import Control.Applicative
import Control.Arrow
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.Bits
import Data.List (sort, insertBy, foldl')
import Data.Maybe (mapMaybe)
import Data.Monoid
import Debug.Trace

readInts :: B.ByteString -> [Int]
readInts = map fst . mapMaybe B.readInt . B.words

getInts :: IO [Int]
getInts = readInts <$> B.getLine

main = do
  [sum, limit] <- getInts
  let
    lbs = map (id &&& ((.&.) <$> id <*> negate)) $ [1..limit]
    s = foldr f (sum, []) (sort lbs)
    f (x, y) (r, xs)
      | r >= y = (r-y, x:xs)
      | otherwise = (r, xs)
   in putStrLn $ if fst s == 0 then (show . length . snd $ s) ++ "\n" ++ (unwords . map show . snd $ s) else "-1"


There are n points on a straight line, and the i-th point among them is located at xi. All these coordinates are distinct.Determine the number m — the smallest number of points you should add on the line to make the distances between all neighboring points equal.

The first line contains a single integer n (3 ≤ n ≤ 100 000) — the number of points. The second line contains a sequence of integers x1, x2, ..., xn ( - 109 ≤ xi ≤ 109) — the coordinates of the points. All these coordinates are distinct. The points can be given in an arbitrary order.

Print a single integer m — the smallest number of points you should add on the line to make the distances between all neighboring points equal.

NoteIn the first example you can add one point with coordinate 0.In the second example the distances between all neighboring points are already equal, so you shouldn't add anything.

module Main where
import Control.Monad
import Control.Applicative
import Data.List

main = do
	n <- read <$> getLine :: IO Int
	a <- sort . map read . words <$> getLine :: IO [Int]
	let b = zipWith (-) (tail a) a
	let g = foldl gcd 0 b
	let h = map (\x -> x `div` g - 1) b
	let ans = sum h
	putStrLn $ show ans
	return ()

import Data.List

main :: IO ()
main = do
    num <- getLine
    temp <- getLine
    let arr = toSub . sorted $ temp
    putStrLn . show $ cal arr (minimum . toGcd $ arr)

sorted :: String -> [Int]
sorted = sort . map read . words

toSub :: [Int] -> [Int]
toSub [_] = []
toSub (x:rest@(y:ys)) = [y - x] ++ toSub rest

toGcd :: [Int] -> [Int]
toGcd [_] = []
toGcd (x:rest@(y:ys)) = [gcd x y] ++ toGcd rest

cal :: [Int] -> Int -> Int
cal lst dis = sum (map (`div` dis) lst) - length lst

import Data.List

main = interact $ show . f . map read . words . last . lines

f :: [Int] -> Int
f ls = ((maximum ls - minimum ls) `div`
  (foldl1' gcd $ zipWith (-) ls (tail ls))) + 1 - length ls

import Data.List (sort)

main = do
	(n:as) <- fmap (map read . words) getContents
	let a = sort as
	let b = zipWith (-) (tail a) a
	let g = foldl1 gcd b
	print $ (quot ((a !! (n - 1)) - (a !! 0)) g) - (n - 1)

import Data.List

solve :: Int -> [Int] -> Int
solve a b =
        (div (maxi - mini) g) - (a-1)
    where
        maxi = maximum b
        mini = minimum b
        l = map (\x -> x-mini) b
        g = foldl gcd (head l) l

main :: IO ()
main = do
  a <- readLn :: IO Int
  ln <- getLine
  let b = map read $ words ln
  print $ solve a b

import Data.List

solve :: Int -> [Int] -> Int
solve a b =
        (div (maxi - mini) g) - (a-1)
    where
        maxi = maximum b
        mini = minimum b
        l = map (\x -> x-mini) b
        g = foldr gcd (head l) l

main :: IO ()
main = do
  a <- readLn :: IO Int
  ln <- getLine
  let b = map read $ words ln
  print $ solve a b

module Main where

solve :: Integer -> [Integer] -> Integer
solve n xs = let
        a1 = minimum xs
        x = foldr1 gcd $ map (\x -> x - a1) xs
        an = maximum xs
    in ((an - a1) `div` x) - n + 1

main :: IO ()
main = do
    n' <- getLine
    xs' <- getLine
    let n = read n' :: Integer
    let xs = map read $ words xs' :: [Integer]
    print $ solve n xs

import Data.List

qweqwe :: [Int] -> Int -> Int
qweqwe (_:[]) ans = ans
qweqwe (a:b) (-1) = qweqwe b ((head b) - a)
qweqwe (a:b) ans = qweqwe b (gcd ans ((head b) - a))

main = do
	getLine
	l <- getLine
	let a = map read $ words l :: [Int]
	let b = sort a
	print (div ((last b) - (head b)) (qweqwe b (-1)) - (length b) + 1)

import Data.List (sort)

diff [] = []
diff (x:[]) = []
diff (x:y:xs) = (y-x):(diff (y:xs))

ggcd [x] = x
ggcd (x:xs) = gcd x (ggcd xs)

res [] g = 0
res (d:ds) g = (d `div` g - 1) + (res ds g)

main = do
  (n:xs) <- fmap (map read . words) getContents
  let ds = diff (sort xs :: [Integer])
  let g = ggcd ds
  print (res ds g)
  -- print ks

import Data.List;

main = getContents >>= (print . f . sort . tail . map mread . words)
	where
		mread n = read n
		maxx [] = -2000000001
		maxx (x : xz) = max x (maxx xz)
		minn [] = 2000000001
		minn (x : xz) = min x (minn xz)
		g _ [] = 0
		g b (x : xz) = gcd (x - b) (g x xz)
		f t@(x :xz) = div (maxx t - minn t)  (g x xz) - length xz

import Data.List

main :: IO ()
main = do
    num <- getLine
    temp <- getLine
    let arr = toSub . sorted $ temp
    putStrLn . show $ cal arr (minimum arr)

sorted :: String -> [Int]
sorted = sort . map read . words

toSub :: [Int] -> [Int]
toSub [_] = []
toSub (x:rest@(y:ys)) = [y - x] ++ toSub rest

toGcd :: [Int] -> [Int]
toGcd [_] = []
toGcd (x:rest@(y:ys)) = [gcd x y] ++ toGcd rest

cal :: [Int] -> Int -> Int
cal lst dis = sum (map (`div` dis) lst) - length lst

import Data.List

main :: IO ()
main = do
    num <- getLine
    temp <- getLine
    let arr = toSub . sorted $ temp
    putStrLn . show $ cal arr (minimum arr)

sorted :: String -> [Int]
sorted = sort . map read . words

toSub :: [Int] -> [Int]
toSub [_] = []
toSub (x:all@(y:ys)) = [y - x] ++ toSub all

cal :: [Int] -> Int -> Int
cal lst dis = sum (map (`div` dis) lst) - length lst

module Main where

solve :: Integer -> [Integer] -> Integer
solve n xs = let
        x = foldr1 gcd xs
        an = maximum xs
        a1 = minimum xs
    in ((an - a1) `div` x) - n + 1

main :: IO ()
main = do
    n' <- getLine
    xs' <- getLine
    let n = read n' :: Integer
    let xs = map read $ words xs' :: [Integer]
    print $ solve n xs

module Main where

solve :: Integer -> [Integer] -> Integer
solve n xs = let
        a1 = minimum xs
        x = foldr1 gcd $ map (+a1) xs
        an = maximum xs
    in ((an - a1) `div` x) - n + 1

main :: IO ()
main = do
    n' <- getLine
    xs' <- getLine
    let n = read n' :: Integer
    let xs = map read $ words xs' :: [Integer]
    print $ solve n xs

import Data.List;

main = getContents >>= (print . f . sort . tail . map mread . words)
	where
		mread n = read n
		maxx [] = -1000000001
		maxx (x : xz) = max x (maxx xz)
		minn [] = 1000000001
		minn (x : xz) = min x (minn xz)
		g _ [] = 0
		g b (x : xz) = gcd (x - b) (g x xz)
		f xz = div (maxx xz - minn xz)  (g 0 xz) - length xz + 1


In this problem you will have to deal with a real algorithm that is used in the VK social network.As in any other company that creates high-loaded websites, the VK developers have to deal with request statistics regularly. An important indicator reflecting the load of the site is the mean number of requests for a certain period of time of T seconds (for example, T = 60 seconds = 1 min and T = 86400 seconds = 1 day). For example, if this value drops dramatically, that shows that the site has access problem. If this value grows, that may be a reason to analyze the cause for the growth and add more servers to the website if it is really needed.However, even such a natural problem as counting the mean number of queries for some period of time can be a challenge when you process the amount of data of a huge social network. That's why the developers have to use original techniques to solve problems approximately, but more effectively at the same time.Let's consider the following formal model. We have a service that works for n seconds. We know the number of queries to this resource at at each moment of time t (1 ≤ t ≤ n). Let's formulate the following algorithm of calculating the mean with exponential decay. Let c be some real number, strictly larger than one.// setting this constant value correctly can adjust   // the time range for which statistics will be calculateddouble c = some constant value; // as the result of the algorithm's performance this variable will contain // the mean number of queries for the last // T seconds by the current moment of timedouble mean = 0.0; for t = 1..n: // at each second, we do the following:    // at is the number of queries that came at the last second;    mean = (mean + at / T) / c;Thus, the mean variable is recalculated each second using the number of queries that came at that second. We can make some mathematical calculations and prove that choosing the value of constant c correctly will make the value of mean not very different from the real mean value ax at t - T + 1 ≤ x ≤ t. The advantage of such approach is that it only uses the number of requests at the current moment of time and doesn't require storing the history of requests for a large time range. Also, it considers the recent values with the weight larger than the weight of the old ones, which helps to react to dramatic change in values quicker.However before using the new theoretical approach in industrial programming, there is an obligatory step to make, that is, to test its credibility practically on given test data sets. Your task is to compare the data obtained as a result of the work of an approximate algorithm to the real data. You are given n values at, integer T and real number c. Also, you are given m moments pj (1 ≤ j ≤ m), where we are interested in the mean value of the number of queries for the last T seconds. Implement two algorithms. The first one should calculate the required value by definition, i.e. by the formula . The second algorithm should calculate the mean value as is described above. Print both values and calculate the relative error of the second algorithm by the formula , where approx is the approximate value, obtained by the second algorithm, and real is the exact value obtained by the first algorithm.

The first line contains integer n (1 ≤ n ≤ 2·105), integer T (1 ≤ T ≤ n) and real number c (1 < c ≤ 100) — the time range when the resource should work, the length of the time range during which we need the mean number of requests and the coefficient c of the work of approximate algorithm. Number c is given with exactly six digits after the decimal point. The next line contains n integers at (1 ≤ at ≤ 106) — the number of queries to the service at each moment of time. The next line contains integer m (1 ≤ m ≤ n) — the number of moments of time when we are interested in the mean number of queries for the last T seconds. The next line contains m integers pj (T ≤ pj ≤ n), representing another moment of time for which we need statistics. Moments pj are strictly increasing.

Print m lines. The j-th line must contain three numbers real, approx and error, where:    is the real mean number of queries for the last T seconds;  approx is calculated by the given algorithm and equals mean at the moment of time t = pj (that is, after implementing the pj-th iteration of the cycle);   is the relative error of the approximate algorithm.  The numbers you printed will be compared to the correct numbers with the relative or absolute error 10 - 4. It is recommended to print the numbers with at least five digits after the decimal point.

import Control.Applicative
import Control.Monad
import Data.Array.Unboxed
import Data.Maybe
import qualified Data.ByteString.Char8 as C

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

main :: IO ()
main = do
  (sn:st:sc:_) <- C.words <$> C.getLine
  let n = readInt sn
      t = readInt st
      c = read $ C.unpack sc
  a <- map readInt . C.words <$> C.getLine
  _m <- C.getLine
  p <- map readInt . C.words <$> C.getLine
  let x, y :: UArray Int Double
      a' = [fromIntegral i / fromIntegral t | i <- a]
      x = listArray (0, n) $ scanl (+) 0 a'
      y = listArray (0, n) $ scanl (\i j -> i / c + j) 0 a'
  forM_ p $ \i -> do
    let real = x!i - x!(i-t)
        approx = y!i / c
        err = abs (real - approx) / real
    putStrLn $ unwords $ map show [real, approx, err]

import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Maybe (fromJust)

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

main = do
	(t, c) <- (\[_, t, c] -> (read t, read c :: Double)) . words <$> getLine
	a <- getInts
	ms <- getInts

	if length ms /= 1
		then putStrLn "botva"
		else putStr ""

	is <- getInts

	let
		output = map (uncurry output') $ select $ zip real approx
			where
				a' = map fromIntegral a
				t' = fromIntegral t

				output' real approx = (real, approx, abs (approx - real) / real)

				real = map (/ t') $ zipWith (-) sums $ replicate t 0 ++ sums
					where
						sums = scanl1 (+) a'

				approx = tail $ scanl (\m a -> (m + a / t') / c) 0.0 a'

				select vs = select' is vs 1
					where
						select' [] _ _ = []
						select' (i:is) (v:vs) j =
							if i == j
								then v : select' is vs (j + 1)
								else select' (i:is) vs (j + 1)

	putStrLn $ unlines $ map (unwords. map show . (\(r, a, e) -> [r, a, e])) output

import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Maybe (fromJust)

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

main = do
	(t, c) <- (\[_, t, c] -> (read t, read c :: Double)) . words <$> getLine
	a <- getInts
	B.getLine
	is <- getInts

	let
		output = map (uncurry output') $ select $ zip real approx
			where
				a' = map fromIntegral a
				t' = fromIntegral t

				output' real approx = (real, approx, abs (approx - real) / real)

				real = map (/ t') $ zipWith (-) sums $ replicate t 0 ++ sums
					where
						sums = scanl1 (+) a'

				approx = tail $ scanl (\m a -> (m + a / t') / c) 0.0 a'

				select vs = select' is vs 1
					where
						select' [] _ _ = []
						select' (i:is) (v:vs) j =
							if i == j
								then v : select' is vs (j + 1)
								else select' (i:is) vs (j + 1)

	putStrLn $ unlines $ map (unwords. map show . (\(r, a, e) -> [r, a, e])) output

import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Maybe (fromJust)

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

main = do
	(t, c) <- (\[_, t, c] -> (read t, read c :: Float)) . words <$> getLine
	a <- getInts
	B.getLine
	is <- getInts

	let
		output = map (uncurry output') $ select $ zip real approx
			where
				a' = map fromIntegral a
				t' = fromIntegral t

				output' real approx = (real, approx, abs (approx - real) / real)

				real = map (/ t') $ zipWith (-) sums $ replicate t 0 ++ sums
					where
						sums = scanl1 (+) a'

				approx = tail $ scanl (\m a -> (m + a / t') / c) 0.0 a'

				select vs = select' is vs 1
					where
						select' [] _ _ = []
						select' (i:is) (v:vs) j =
							if i == j
								then v : select' is vs (j + 1)
								else select' (i:is) vs (j + 1)

	putStrLn $ unlines $ map (unwords. map show . (\(r, a, e) -> [r, a, e])) output

import Control.Applicative ((<$>))

main = do
	(n, t, c) <- (\[n, t, c] -> (read n :: Int, read t :: Int, read c :: Float)) . words <$> getLine
	a <- map read . words <$> getLine
	getLine
	is <- map read . words <$> getLine

	let
		real = map (\v -> (fromIntegral v) / (fromIntegral t)) $ zipWith (-) sums $ (replicate t 0) ++ sums
			where
				sums = scanl1 (+) a

		approx = tail $ scanl (\m a -> (m + (fromIntegral a) / (fromIntegral t)) / c) 0.0 a

		select vs = select' is vs 1
			where
				select' [] _ _ = []
				select' (i:is) (v:vs) j =
					if i == j
						then v : select' is vs (j + 1)
						else select' (i:is) vs (j + 1)

		output = map calc $ zip (select real) (select approx)
			where
				calc (real, approx) = (real, approx, abs (approx - real) / real)

	putStrLn $ unlines $ map (\(r, a, e) -> show r ++ " " ++ show a ++ " " ++ show e) output

{-# OPTIONS_GHC -O2 #-}

import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Maybe

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

main = do
	(n, t, c) <- (\[n, t, c] -> (read n :: Int, read t :: Int, read c :: Double)) . words <$> getLine
	a <- getInts
	getLine
	is <- getInts

	let
		real = map (\v -> (fromIntegral v) / (fromIntegral t)) $ zipWith (-) sums $ (replicate t 0) ++ sums
			where
				sums = scanl1 (+) a

		approx = tail $ scanl (\m a -> (m + (fromIntegral a) / (fromIntegral t)) / c) 0.0 a

		select vs = select' is vs 1
			where
				select' [] _ _ = []
				select' (i:is) (v:vs) j =
					if i == j
						then v : select' is vs (j + 1)
						else select' (i:is) vs (j + 1)

		output = map calc $ zip (select real) (select approx)
			where
				calc (real, approx) = (real, approx, abs (approx - real) / real)

	putStrLn $ unlines $ map (\(r, a, e) -> show r ++ " " ++ show a ++ " " ++ show e) output

import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Maybe (fromJust)

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

main = do
	(t, c) <- (\[_, t, c] -> (read t, read c :: Double)) . words <$> getLine
	a <- getInts
	getLine
	is <- getInts

	let
		output = map (uncurry output') $ select $ zip real approx
			where
				a' = map fromIntegral a
				t' = fromIntegral t

				output' real approx = (real, approx, abs (approx - real) / real)

				real = map (/ t') $ zipWith (-) sums $ replicate t 0 ++ sums
					where
						sums = scanl1 (+) a'

				approx = tail $ scanl (\m a -> (m + a / t') / c) 0.0 a'

				select vs = select' is vs 1
					where
						select' [] _ _ = []
						select' (i:is) (v:vs) j =
							if i == j
								then v : select' is vs (j + 1)
								else select' (i:is) vs (j + 1)

	putStrLn $ unlines $ map (unwords. map show . (\(r, a, e) -> [r, a, e])) output

{-# OPTIONS_GHC -O2 #-}

import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Maybe

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

main = do
	(n, t, c) <- (\[n, t, c] -> (read n :: Int, read t :: Int, read c :: Double)) . words <$> getLine
	a <- getInts
	getLine
	is <- getInts

	let
		real = map (\v -> v / (fromIntegral t)) $ zipWith (-) sums $ (replicate t 0) ++ sums
			where
				sums = scanl1 (+) $ map (\v -> fromIntegral v :: Double) a

		approx = tail $ scanl (\m a -> (m + (fromIntegral a) / (fromIntegral t)) / c) 0.0 a

		select vs = select' is vs 1
			where
				select' [] _ _ = []
				select' (i:is) (v:vs) j =
					if i == j
						then v : select' is vs (j + 1)
						else select' (i:is) vs (j + 1)

		output = map calc $ zip (select real) (select approx)
			where
				calc (real, approx) = (real, approx, abs (approx - real) / real)

	putStrLn $ unlines $ map (\(r, a, e) -> show r ++ " " ++ show a ++ " " ++ show e) output


A tree is a graph with n vertices and exactly n - 1 edges; this graph should meet the following condition: there exists exactly one shortest (by number of edges) path between any pair of its vertices.A subtree of a tree T is a tree with both vertices and edges as subsets of vertices and edges of T.You're given a tree with n vertices. Consider its vertices numbered with integers from 1 to n. Additionally an integer is written on every vertex of this tree. Initially the integer written on the i-th vertex is equal to vi. In one move you can apply the following operation:  Select the subtree of the given tree that includes the vertex with number 1.  Increase (or decrease) by one all the integers which are written on the vertices of that subtree. Calculate the minimum number of moves that is required to make all the integers written on the vertices of the given tree equal to zero.

The first line of the input contains n (1 ≤ n ≤ 105). Each of the next n - 1 lines contains two integers ai and bi (1 ≤ ai, bi ≤ n; ai ≠ bi) indicating there's an edge between vertices ai and bi. It's guaranteed that the input graph is a tree.  The last line of the input contains a list of n space-separated integers v1, v2, ..., vn (|vi| ≤ 109).

Print the minimum number of operations needed to solve the task. Please, do not write the %lld specifier to read or write 64-bit integers in С++. It is preferred to use the cin, cout streams or the %I64d specifier.

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

import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Control.Monad.ST
import Data.Array (Array)
import Data.Array.Base
import Data.Array.ST (runSTArray, STArray)
import qualified Data.ByteString.Char8 as B
import qualified Data.IntSet as IS
import Data.Ix
import Data.List

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

toPairs (x:y:xys) = (x,y) : toPairs xys
toPairs _ = []

unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

main :: IO ()
main = do
  n <- readLn
  (xs,vs) <- splitAt (2*(n-1)).map readInt.B.words <$> B.getContents
  let arr = listArray (0,n) $ 0:vs
      edges = toPairs xs
  print $ solve arr edges

type Vertex = Int
type Edge = (Vertex, Vertex)
type Graph = Array Vertex [Vertex]

mkGraph :: UArray Int Int -> [Edge] -> Graph
mkGraph arr edges = runSTArray $ do
  mgr <- newArray (bounds arr) [] :: ST s (STArray s Vertex [Vertex])
  forM_ edges $ \(s,t) -> do
    unsafeModify mgr s (t:)
    unsafeModify mgr t (s:)
  return mgr

solve :: UArray Int Int -> [Edge] -> Integer
solve arr edges = uncurry (+) $ go (IS.singleton 1) 1
  where
    gr = mkGraph arr edges
    go visited i
      | null childs = force (max 0 v, abs $ min 0 v)
      | otherwise = force (max 0 v'+x, abs(min 0 v')+y)
      where
        v = fromIntegral $ unsafeAt arr i
        childs = filter (`IS.notMember` visited) $ unsafeAt gr i
        (x,y) = foldl1' max' $ map (go $ IS.insert i visited) childs
        max' (!x,!y) (!z,!w) = (max x z, max y w)
        v' = v-x+y


Almost every text editor has a built-in function of center text alignment. The developers of the popular in Berland text editor «Textpad» decided to introduce this functionality into the fourth release of the product.You are to implement the alignment in the shortest possible time. Good luck!

The input file consists of one or more lines, each of the lines contains Latin letters, digits and/or spaces. The lines cannot start or end with a space. It is guaranteed that at least one of the lines has positive length. The length of each line and the total amount of the lines do not exceed 1000.

Format the given text, aligning it center. Frame the whole text with characters «*» of the minimum size. If a line cannot be aligned perfectly (for example, the line has even length, while the width of the block is uneven), you should place such lines rounding down the distance to the left or to the right edge and bringing them closer left or right alternatively (you should start with bringing left). Study the sample tests carefully to understand the output format better.

welcome to the
Codeforces
Beta
Round 5

and
good luck

import Control.Monad (liftM)
import Data.List (intercalate)
import Prelude hiding (reads)

reads :: Read a => IO [a]
reads  =  liftM (map read . words) getLine

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

solve :: [String] -> [String]
solve ss  =  concat
    [[colontitul],
     map snd $ tail $ scanl solve' (True, "") ss,
     [colontitul]]
  where
    n  =  maximum $ map length ss
    colontitul  =  replicate (n+2) '*'
    solve' (b, _) s
      | s == ""  =  (b, "*" ++ replicate n ' ' ++ "*")
      | length s' < n  =  if b
          then (not b, "*" ++ s' ++ " *")
          else (not b, "* " ++ s' ++ "*")
      | otherwise  =  (b, "*" ++ s' ++ "*")
      where
        m  =  length s
        k  =  (n - m) `div` 2
        s'  =  concat
            [replicate k ' ', s, replicate k ' ']

main :: IO ()
main  =  getContents >>= putStrLn . unlines . solve . lines

import Control.Monad

main = do
    texts <- fmap lines getContents
    let chars = maximum $ map length texts
    putStrLn $ replicate (chars + 2) '*'
    foldM' texts $ \left s -> do
        let len = length s
            x = replicate ((chars - len) `div` 2) ' '
            y | (chars - len) `mod` 2 == 0 = x
              | otherwise = ' ':x
            (leftSpace, rightSpace)
                | left = (y, x)
                | otherwise = (x, y)
            newLeft | (chars - len) `mod` 2 == 0 = left
                    | otherwise = not left
        putStrLn $ "*" ++ leftSpace ++ s ++ rightSpace ++ "*"
        return newLeft
    putStrLn $ replicate (chars + 2) '*'

foldM' xs f = foldM_ f False xs

import Control.Applicative
import Control.Monad
import Data.List

solve :: [String] -> [String]
solve = do
  ss <- id
  let ws = map length ss
  let wmax = maximum ws
  let ls = snd $ mapAccumL check 0 (map (`subtract` wmax) ws) where
        check acc n | even n    = (acc, n `quot` 2)
                    | otherwise = ((acc + 1) `rem` 2, (n + acc) `quot` 2)
  let hs = return $ replicate (wmax + 2) '*'
  let fs = hs
  let contens = do (w, l, s) <- zip3 ws ls ss
                   return $  "*"
                          ++ replicate l ' '
                          ++ s
                          ++ replicate (wmax - l - w) ' '
                          ++ "*"
  return $ hs ++ contens ++ fs

main = interact $ unlines . solve . lines

main = do
    l <- lines `fmap` getContents
    let placeLength = maximum $ map length l
        center (left, res) s =
            let diff = placeLength - length s
                half = diff `div` 2
                r' = (flip replicate) ' '
                (l, r) = case (left, diff) of
                    _ | even diff -> (left, r' half ++ s ++ r' half)
                      | odd diff && left -> (not left, r' half ++ s ++ r' (half + 1))
                      | otherwise -> (not left, r' (half + 1) ++ s ++ r' half) in
            (l, ('*':r++"*"):res)
        stars = putStrLn $ replicate (placeLength + 2) '*'
    stars
    mapM putStrLn $ reverse $ snd $ foldl center (True, []) l
    stars

import Data.List

main = interact $ (dump . solve . load) where
	load :: String -> [String]
	load = lines

	dump :: [String] -> String
	dump = unlines

	solve :: [String] -> [String]
	solve ls =
		let
			maxLen = foldl1' max $ map length $ ls
			fillLR s left right = '*' : (replicate left ' ') ++ s ++ (replicate right ' ') ++ "*"
			fill s toLeft =
				let
					half = (maxLen - length s) `div` 2
				in
					if half * 2 == maxLen - length s then (fillLR s half half, toLeft)
					else
						if toLeft then (fillLR s half (half + 1), not toLeft)
						else (fillLR s (half + 1) half, not toLeft)

			alter :: Bool -> [String] -> [String] -> [String]
			alter _ [] acc          = reverse acc
			alter tl (x:xs) acc =
				let
					(s, ntl) = fill x tl
				in
					alter ntl xs (s : acc)
		in
			(replicate (maxLen + 2) '*') : (alter True ls []) ++ [(replicate (maxLen + 2) '*')]

ast n = replicate n '*'
spc n = replicate n ' '

f w [] _ = []
f w (l:ls) left =
  let n = (w-length l) `div` 2
  in if (w-length l) `mod` 2 == 0 then
        ("*"++spc n++l++spc n++"*") : f w ls left
     else
        ("*"++spc (n+left)++l++spc (n+1-left)++"*") : f w ls (1-left)

main = do
     contents <- return . lines =<< getContents
     let w = maximum $ map length contents
     mapM_ putStrLn $ [ast (w+2)]++f w contents 0++[ast (w+2)]

{-# LANGUAGE OverloadedStrings #-}
module Main where

import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Control.Monad (foldM_)
import Data.Functor (($>))

main :: IO ()
main = do
    ls <- T.lines <$> TIO.getContents
    let maxLength = maximum $ map T.length ls
    let frameStr = T.replicate (maxLength + 2) "*"
    TIO.putStrLn frameStr
    foldM_ (putFormattedStr maxLength) 0 ls
    TIO.putStrLn frameStr

putFormattedStr :: Int -> Int -> T.Text -> IO Int
putFormattedStr len add line = TIO.putStrLn formattedLine $> rem
  where
    spareLen = len - T.length line
    (left, rem) = (spareLen + add) `quotRem` 2
    right = spareLen - left
    formattedLine = "*" <> T.replicate left " " <> line <> T.replicate right " " <> "*"

{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -O2 #-}
import Debug.Trace
import Data.List
import Control.Monad
import Data.Char
import Data.Bits((.&.))
data Dir = L|R deriving (Eq)
indicator :: Bool -> Int
indicator b = if b then 1 else 0
revd :: Dir -> Dir
revd L = R
revd R = L

solve lns = let maxlength = (maximum.map length) lns
                w n = replicate n ' '
                rec [] _ = [replicate (maxlength+2) '*']
                rec (x:xs) dir = let margin = maxlength - (length x)
                                     leftm = div margin 2 +(indicator (dir==R&&odd margin))
                                     rightm =div margin 2 +(indicator (dir==L&&odd margin))
                                 in
                                   ('*':(w leftm)++x++(w rightm)++"*"):(if odd margin then rec xs (revd dir) else rec xs dir)
                in
                  (replicate (maxlength+2) '*'):(rec lns L)

main = do input <- getContents
          let lns = lines input
          mapM_ putStrLn (solve lns)

-- http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html

copy :: Char -> Int -> String
copy _ 0 = ""
copy c n = c:(copy c (n - 1))

printAns :: Int -> Int -> [String] -> IO()
printAns w par (a:b)
    | a == "" = do
        putStrLn ("*" ++ (copy ' ' w) ++ "*")
        printAns w par b
    | mod s 2 == 0  = do
        putStrLn ("*" ++ (copy ' ' (div s 2)) ++ a ++ (copy ' ' (div s 2)) ++ "*")
        printAns w par b
    | otherwise     = do
        putStrLn ("*" ++ (copy ' ' (div s 2 + par)) ++ a ++ (copy ' ' (div s 2 + 1 - par)) ++ "*")
        printAns w (1 - par) b
        where s = w - length a
printAns _ _ _ = do
    putStr ""

main :: IO()
main = do
    input <- getContents
    let list = lines input
    let w = maximum (1 : map length list)
    putStrLn (copy '*' (w + 2))
    printAns w 0 list
    putStrLn (copy '*' (w + 2))

g w  = take w $ repeat '*'
sp w = take w $ repeat ' '

out :: Int -> [String] -> Bool -> [String]
out width [] _ = []
out width (s:sx) left | (width - length s) `mod` 2 == 0 =
    let w = (width - length s) `div` 2
    in ( sp w ++ s ++ sp w ):(out width sx left)
                      | True =
    ( sp (c w left) ++ s ++ sp (c w (not left)) ):(out width sx (not left))
        where w = (width - length s) `div` 2
              c w True = w
              c w False = w+1

main = do
    s <- getContents
    let l = lines s
        width = maximum $ map length l
        output = [g width] ++ out width l True ++ [g width]
    mapM_ putStrLn $ map (\a -> "*" ++ a ++ "*") output

module Main (main) where

main = do
    instr <- getContents
    let ls = lines instr
    putStr $ unlines $ solve ls where

        solve ls = stars (reverse (wrap (-1) (zip lens ls) [])) where

            max = maximum lens
            lens = map length ls
            probels = repeat ' '

            wrap _ [] acc = acc
            wrap lr ((len, s):ss) acc = if even razn
                then wrap lr ss ((probs ++ s ++ probs):acc)
                else if lr > 0 then wrap (-lr) ss ((probs ++ " " ++ s ++ probs):acc)
                               else wrap (-lr) ss ((probs ++ s ++ probs ++ " "):acc) where
                razn = max - len
                r2 = div razn 2
                probs = take r2 probels

            stars ss = starn ++ map wrstar ss ++ starn where
                starn = [take (max + 2) $ repeat '*']
                wrstar s = "*" ++ s ++ "*"

import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import Data.Text.Encoding
import Data.Char
import Data.List

main =  do
    t <- map (T.filter (\x -> isAlphaNum x || x == ' ')) . T.lines . decodeUtf8 <$> B.getContents
    let (ls, m) = (map T.length t, maximum ls)
        bs = tail $ reverse $ foldl' (\acc@(b:_) x -> if x < m && (x-m)`mod`2/=0 then (not b:acc) else b:acc) [True] ls
        border = T.pack $ replicate (m+2) '*'
    B.putStrLn $ encodeUtf8 $ T.unlines $ (border : zipWith  (\x b -> T.append ( T.cons '*' $ if b then T.center m ' ' x else T.reverse $ T.center m ' ' $ T.reverse x) $ T.pack "*") t bs )  ++ [border]

import Control.Monad

main = do
    texts <- fmap lines getContents
    let chars = maximum $ map length texts
    putStrLn $ replicate (chars + 2) '*'
    forM_ texts $ \s -> do
        let len = length s
            leftSpace = replicate ((chars - len) `div` 2) ' '
            rightSpace | (chars - len) `mod` 2 == 0 = leftSpace
                       | otherwise = ' ':leftSpace
        putStrLn $ "*" ++ leftSpace ++ s ++ rightSpace ++ "*"
    putStrLn $ replicate (chars + 2) '*'

import Control.Applicative
import Control.Monad
import Data.List

-- Seems to be OK?
solve :: [String] -> [String]
solve = do
  ss <- id
  let w = maximum $ map length ss
  return ss

main = interact $ unlines . solve . lines

import Control.Applicative
import Control.Monad
import Data.List

-- Compile Check
-- How come we can't use function monad?

solve :: [String] -> [String]
solve = do
  s <- id
  return s

main = interact $ unlines . solve . lines

main = do
    l <- lines `fmap` getContents
    let placeLength = maximum $ map length l
        center (left, res) s =
            let diff = placeLength - length s
                half = diff `div` 2
                r' = (flip replicate) ' '
                (l, r) = case (left, diff) of
                    _ | even diff -> (left, r' half ++ s ++ r' half)
                      | odd diff && left -> (not left, r' half ++ s ++ r' (half + 1))
                      | otherwise -> (not left, r' half ++ s ++ r' (half + 1)) in
            (l, ('*':r++"*"):res)
        stars = putStrLn $ replicate (placeLength + 2) '*'
    stars
    mapM putStrLn $ reverse $ snd $ foldl center (True, []) l
    stars

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.IO as TIO

main :: IO ()
main = do
    ls <- T.lines <$> TIO.getContents
    let maxLength = maximum $ map T.length ls
    let frameStr = T.replicate (maxLength + 2) "*"
    TIO.putStrLn frameStr
    mapM_ (TIO.putStrLn . formatStr maxLength) ls
    TIO.putStrLn frameStr
  where
    center len line = T.replicate left " " <> line <> T.replicate (len - T.length line - left) " " where left = (len - T.length line) `div` 2
    formatStr len line = "*" <> center len line <> "*"

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.IO as TIO

main :: IO ()
main = do
    ls <- T.lines <$> TIO.getContents
    let maxLength = maximum $ map T.length ls
    let frameStr = T.replicate (maxLength + 2) "*"
    TIO.putStrLn frameStr
    mapM_ (TIO.putStrLn . formatStr maxLength) ls
    TIO.putStrLn frameStr
  where
    formatStr len instr = "*" <> T.center len ' ' instr <> "*"

import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import Data.Text.Encoding

main =  do
    t <- T.lines . decodeUtf8 <$> B.getContents
    let m = foldr (\x acc -> max acc $ T.length x) 0 t
        border = T.pack $ replicate (m+2) '*'
    B.putStrLn $ encodeUtf8 $ T.unlines $ (border : map (\x -> T.append ( T.cons '*' $ T.reverse $ T.center m ' ' $ T.reverse x) $ T.pack "*") t )  ++ [border]

import Control.Monad (liftM)
import Data.List (intercalate)
import Prelude hiding (reads)

reads :: Read a => IO [a]
reads  =  liftM (map read . words) getLine

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

solve :: [String] -> [String]
solve ss  =  concat
    [[colontitul],
     map snd $ tail $ scanl solve' (True, "") ss,
     [colontitul]]
  where
    n  =  maximum $ map length ss
    colontitul  =  replicate (n+2) '*'
    solve' (b, _) s
      | s == ""  =  (b, replicate n ' ')
      | length s' < n  =  if b
          then (not b, "*" ++ s' ++ " *")
          else (not b, "* " ++ s' ++ "*")
      | otherwise  =  (b, "*" ++ s' ++ "*")
      where
        m  =  length s
        k  =  (n - m) `div` 2
        s'  =  concat
            [replicate k ' ', s, replicate k ' ']

main :: IO ()
main  =  getContents >>= putStrLn . unlines . solve . lines


This is the easy version of the problem. The only difference from the hard version is that in this version all coordinates are even.There are $$$n$$$ fence-posts at distinct coordinates on a plane. It is guaranteed that no three fence posts lie on the same line.There are an infinite number of cows on the plane, one at every point with integer coordinates.Gregor is a member of the Illuminati, and wants to build a triangular fence, connecting $$$3$$$ distinct existing fence posts. A cow strictly inside the fence is said to be enclosed. If there are an odd number of enclosed cows and the area of the fence is an integer, the fence is said to be interesting.Find the number of interesting fences.

The first line contains the integer $$$n$$$ ($$$3 \le n \le 6000$$$), the number of fence posts which Gregor can choose to form the vertices of a fence. Each of the next $$$n$$$ line contains two integers $$$x$$$ and $$$y$$$ ($$$0 \le x,y \le 10^7$$$, $$$x$$$ and $$$y$$$ are even), where $$$(x,y)$$$ is the coordinate of a fence post. All fence posts lie at distinct coordinates. No three fence posts are on the same line.

Print a single integer, the number of interesting fences. Two fences are considered different if they are constructed with a different set of three fence posts.

NoteIn the first example, there is only $$$1$$$ fence. That fence is interesting since its area is $$$4$$$ and there is $$$1$$$ enclosed cow, marked in red.  In the second example, there are $$$3$$$ interesting fences.   $$$(0,0)$$$ — $$$(30,14)$$$ — $$$(2,10)$$$  $$$(2,16)$$$ — $$$(30,14)$$$ — $$$(2,10)$$$  $$$(30,14)$$$ — $$$(4,6)$$$ — $$$(2,10)$$$

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

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

import Data.Array.Unboxed
import Data.Int

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [n] <- readInts
  pts <- replicateM n $ do
    [x, y] <- readInts
    pure $ mod x 4 + mod y 4 `quot` 2
  let
    cts :: UArray Int Int64
    cts = accumArray (\x () -> x + 1) 0 (0, 3) $ zip pts $ repeat ()
    t21 = (`div` 2) $ foldl' (+) 0 $ do
      (i, ci) <- assocs cts
      (j, cj) <- assocs cts
      guard $ i /= j
      pure $ ci * (ci - 1) * cj
    -- don't forget this like a dummy
    t3 = (`div` 6) $ foldl' (\x y -> x + y * (y-1) * (y-2)) 0 $ elems cts
  putInt64s [t21 + t3]

type SIO = StateT P.ByteString IO

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

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

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

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

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

import Data.Array.Unboxed
import Data.Int

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [n] <- readInts
  pts <- replicateM n $ do
    [x, y] <- readInts
    pure $ mod x 4 + mod y 4 `quot` 2
  let
    cts :: UArray Int Int64
    cts = accumArray (\x () -> x + 1) 0 (0, 3) $ zip pts $ repeat ()
    total = foldl' (+) 0 $ do
      (i, ci) <- assocs cts
      (j, cj) <- assocs cts
      guard $ i /= j
      pure $ ci * (ci - 1) * cj
  putInt64s [div total 2]

type SIO = StateT P.ByteString IO

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

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

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


Caisa is going to have a party and he needs to buy the ingredients for a big chocolate cake. For that he is going to the biggest supermarket in town.Unfortunately, he has just s dollars for sugar. But that's not a reason to be sad, because there are n types of sugar in the supermarket, maybe he able to buy one. But that's not all. The supermarket has very unusual exchange politics: instead of cents the sellers give sweets to a buyer as a change. Of course, the number of given sweets always doesn't exceed 99, because each seller maximizes the number of dollars in the change (100 cents can be replaced with a dollar).Caisa wants to buy only one type of sugar, also he wants to maximize the number of sweets in the change. What is the maximum number of sweets he can get? Note, that Caisa doesn't want to minimize the cost of the sugar, he only wants to get maximum number of sweets as change.

The first line contains two space-separated integers n, s (1 ≤ n, s ≤ 100). The i-th of the next n lines contains two integers xi, yi (1 ≤ xi ≤ 100; 0 ≤ yi < 100), where xi represents the number of dollars and yi the number of cents needed in order to buy the i-th type of sugar.

Print a single integer representing the maximum number of sweets he can buy, or -1 if he can't buy any type of sugar.

NoteIn the first test sample Caisa can buy the fourth type of sugar, in such a case he will take 50 sweets as a change.

main=getContents>>=print.s.map(map read.words).lines
s([_,s]:x)=maximum$ -1:[if y>0 then 100-y else 0|[x,y]<-x,x*100+y<=s*100]

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

solve :: [Int] -> Int
solve (m:a) = solve' a
    where solve' :: [Int] -> Int
          solve' [] = -1
          solve' (x:y:s) | m > x && y == 0 = max 0 (solve' s)
                         | m > x = max (100 - y) (solve' s)
                         | m == x && y == 0 = max 0 (solve' s)
                         | otherwise = solve' s

import Data.List
import Data.Function
import Data.Char
import Data.Maybe
import qualified Data.ByteString.Lazy.Char8 as B

getIntArray :: B.ByteString -> [Int]
getIntArray = map fst . mapMaybe B.readInt . B.words

main = B.interact $ B.pack . show . getAns . getIntArray

getAns :: [Int] -> Int
getAns (_:s:xs) = calMax s xs

calMax :: Int -> [Int] -> Int
calMax _ [] = -1
calMax s (x:y:xs) = let nm = if (x * 100 + y <= s * 100) then mod (100 - y) 100 else -1;
					in max nm $ calMax s xs

main = interact $ show . f . map read . tail . words
f (s:[]) = -1
f (s:x:y:z) = max (if s * 100 < x * 100 + y then -1 else mod (s * 100 - x * 100 - y) 100) $ f (s:z)

import Data.List
import Control.Monad
import Control.Applicative

ans n = sort . map ((`mod`100) . (n-)) . filter (<= n) . map cost
	where cost [d,c] = d*100 + c

solve [] = -1
solve l = last l

main = do
		[n,s] <- map read . words <$> getLine
		xy <- replicateM n $ map read . words <$> getLine
		let cent = 100*s
      		print $ solve $ ans cent xy

-- Codeforces 463A

main :: IO ()
main = do
    [n, s] <- fmap (map read . words) getLine
    getContents >>= print . solve s . map (map read . words) . lines

solve :: Int -> [[Int]] -> Int
solve s xs = if length enough == 0 then (-1) else 100 - (minimum $ (100:) $ filter (/= 0) $ map (!!1) enough)  where enough = filter (\[a,b] -> a<s || a==s && b==0) xs
                                                                -- prepend 100: to avoid empty list error.

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

solve :: [[Integer]] -> Integer
solve ([_, s] : xys) = maximum $ -1 : [ if y > 0 then 100 - y else 0 | [ x, y ] <- xys, x * 100 + y <= s * 100 ]
solve _ = undefined

parse :: String -> (Int, Int)
parse s = case map read (words s) of [x, y] -> (x, y)
price (x, y) = x * 100 + y
solve ((_,s):xs) = maximum $ (-1) : [if y > 0 then 100 - y else 0 | t@(_, y) <- xs, price t <= s * 100]
main = putStrLn . show . solve . map parse . lines =<< getContents

import Control.Monad
s([_,s]:l)=maximum ((-1):(l>>=(\[d,c]->guard(d*100+c<=s*100)>>[if c==0 then 0 else 100-c])))
main=interact$show.s.map(map read.words).lines

import Control.Applicative
import Data.List

main=do
	[n,s]<-  map read.words  <$> getLine:: IO [Int]
	t<- map (map read). map words . lines <$> getContents :: IO [[Int]]
	let t1 =  map last $ filter (\z-> head z<s || (head z==s && last z==0)) t
	print $ if length t1==0 then (-1)
                                else if length (filter (/=0) t1)==0 then 0
                                                                    else 100-(minimum (filter (/=0) t1))

main = interact $ show . sol . map read . words

sol (_:s:xs) = cal $ ok s xs

cal [] = -1
cal xs = maximum . map ((`mod`100).(100-).snd) $ xs

ok s = filter (\(a, b) -> a < s || (a==s && b==0)) . tp

tp [] = []
tp (f:s:xs) = (f, s):(tp xs)

parse :: String -> (Int, Int)
parse s = case map read (words s) of [x, y] -> (x, y)
price (x, y) = x * 100 + y
maxCents s p@(x, y) = maximum . map (`mod` 100) . takeWhile (> 0) $ map (\x -> s - price p * x) [1..]
solve ((_,s'):xs) = let s = s' * 100 in case filter (\x -> price x <= s) xs of
    [] -> (-1)
    rs -> maximum $ map (maxCents s) rs
main = putStrLn . show . solve . map parse . lines =<< getContents

import Control.Applicative
import Data.List

main=do
	[n,s]<-  map read.words  <$> getLine:: IO [Int]
	t<- map (map read). map words . lines <$> getContents :: IO [[Int]]
	let t1 =  map last $ filter (\z-> head z<s) t
	print $ if length t1==0 then (-1)
                                else if length (filter (/=0) t1)==0 then 0
                                                                    else 100-(minimum (filter (/=0) t1))


Mihai plans to watch a movie. He only likes palindromic movies, so he wants to skip some (possibly zero) scenes to make the remaining parts of the movie palindromic.You are given a list $$$s$$$ of $$$n$$$ non-empty strings of length at most $$$3$$$, representing the scenes of Mihai's movie.A subsequence of $$$s$$$ is called awesome if it is non-empty and the concatenation of the strings in the subsequence, in order, is a palindrome.Can you help Mihai check if there is at least one awesome subsequence of $$$s$$$?A palindrome is a string that reads the same backward as forward, for example strings "z", "aaa", "aba", "abccba" are palindromes, but strings "codeforces", "reality", "ab" are not.A sequence $$$a$$$ is a non-empty subsequence of a non-empty sequence $$$b$$$ if $$$a$$$ can be obtained from $$$b$$$ by deletion of several (possibly zero, but not all) elements.

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 a single integer $$$n$$$ ($$$1 \le n \le 10^5$$$) — the number of scenes in the movie. Then follows $$$n$$$ lines, the $$$i$$$-th of which containing a single non-empty string $$$s_i$$$ of length at most $$$3$$$, consisting of lowercase Latin letters. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$10^5$$$.

For each test case, print "YES" if there is an awesome subsequence of $$$s$$$, or "NO" otherwise (case insensitive).

6

5

zx

ab

cc

zx

ba

2

ab

bad

4

co

def

orc

es

3

a

b

c

3

ab

cd

cba

2

ab

ab

NoteIn the first test case, an awesome subsequence of $$$s$$$ is $$$[ab, cc, ba]$$$

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.Maybe

--import Data.ByteString.Builder.Extra (flush) -- for interactive problems
import Control.Monad
import qualified Data.Set as Set

mainFun :: SP Builder
mainFun = do
  t <- getInt
  fmap mconcat $ replicateM t $ do
    n <- getInt
    opts <- replicateM n getNext
    let
      solve :: Set.Set P.ByteString -> [P.ByteString] -> Bool
      solve _ [] = False
      solve s (x : xs) = let
        s' = Set.insert x s
        in  (|| solve s' xs) $ or $ case  P.length x  of
        1 -> [True]
        2 -> do
          let  xr = P.reverse x
          [Set.member v s' | v <- xr : map (P.snoc xr) ['a'..'z']]
        3 -> do
          let  xr = P.reverse x
          [Set.member v s' | v <- [xr, P.init xr]]
    pure $ string7 $ if  solve Set.empty opts
      then  "YES\n"
      else  "NO\n"

type SP = State P.ByteString
type S = StateT P.ByteString

dropSpace :: P.ByteString -> P.ByteString
dropSpace = P.dropWhile (<= ' ') -- not exactly right, but close enough

getNext :: Monad m => S m P.ByteString
getNext = state $ P.span (> ' ') . dropSpace

getInt :: Monad m => S m Int
getInt = state $ fromJust . P.readInt . dropSpace

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 inp
  P.putStr $ toLazyByteString outp


First-rate specialists graduate from Berland State Institute of Peace and Friendship. You are one of the most talented students in this university. The education is not easy because you need to have fundamental knowledge in different areas, which sometimes are not related to each other. For example, you should know linguistics very well. You learn a structure of Reberland language as foreign language. In this language words are constructed according to the following rules. First you need to choose the "root" of the word — some string which has more than 4 letters. Then several strings with the length 2 or 3 symbols are appended to this word. The only restriction —  it is not allowed to append the same string twice in a row. All these strings are considered to be suffixes of the word (this time we use word "suffix" to describe a morpheme but not the few last characters of the string as you may used to). Here is one exercise that you have found in your task list. You are given the word s. Find all distinct strings with the length 2 or 3, which can be suffixes of this word according to the word constructing rules in Reberland language. Two strings are considered distinct if they have different length or there is a position in which corresponding characters do not match. Let's look at the example: the word abacabaca is given. This word can be obtained in the following ways: , where the root of the word is overlined, and suffixes are marked by "corners". Thus, the set of possible suffixes for this word is {aca, ba, ca}.

The only line contains a string s (5 ≤ |s| ≤ 104) consisting of lowercase English letters.

On the first line print integer k — a number of distinct possible suffixes. On the next k lines print suffixes.  Print suffixes in lexicographical (alphabetical) order.

NoteThe first test was analysed in the problem statement. In the second example the length of the string equals 5. The length of the root equals 5, so no string can be used as a suffix.

import qualified Data.IntMap as IM
import Data.Char
import Data.IntMap ((!))
import Data.Ix (Ix, index, range)
import Data.List

main = do
    s <- getContents
    let strings = solve . filter (not.isSpace) $ s
    print $ length strings
    mapM_ putStrLn strings

solve s = map head . group . sort $ strings
  where
    ms = IM.fromList $ zip [0..] (reverse s)
    n = IM.size ms

    f _ (_, m) | n-m <= 5 = False
    f _ (2, 1) = True
    f _ (3, 2) = True
    f _ (_, m) | m <= 2 = False
    f rec (prev, m) = rec (5-prev, m-prev) || (rec (prev, m-prev) && not (eq (m-2*prev) (m-prev)))

    eq a b = and $ zipWith (==) (map (ms!) [a+1..b]) (map (ms!) [b+1 .. 2*b-a])

    isGood = immemo f (2,0) (3,n-1)

    good2 = [i | i <- [1..n-1], isGood (2, i)]
    good3 = [i | i <- [2..n-1], isGood (3, i)]
    strings = [[ms!i, ms!(i-1)] | i <- good2] ++ [[ms!i, ms!(i-1), ms!(i-2)] | i <- good3]

immemo :: (Ix i) => ((i -> a) -> i -> a) -> i -> i -> i -> a
immemo f l r = memo
  where
    ix = index (l,r)
    memo = (IM.!) dp . ix
    dp = IM.fromList [(ix k, f memo k) | k <- range (l,r)]

{-
instructions go here...
-}

module Main where
import Data.List (group, sort, splitAt)
import Data.Set (Set(..), empty, singleton, toList, insert, unions, member)

solve :: String -> [String]
solve str = sort . toList . nth3_3 . foldr f f0 $ (drop 5 str)
  where f0 = ([True,False,False,False,False], "-----", empty)
        f :: Char -> ([Bool],[Char],Set String) -> ([Bool],[Char],Set String)
        f x0 (oks@[ok1,ok2,ok3,ok4,ok5], xs@[x1,x2,x3,x4,x5], suffixes) =
          let ok02 = ok2 && ok5
                  || ok2 && [x0,x1] /= [x2,x3]
              ok03 = ok3 && ok5
                  || ok3 && [x0,x1,x2] /= [x3,x4,x5]
              suffixes' = unions [ suffixes
                                 , if ok02 then singleton [x0,x1] else empty
                                 , if ok03 then singleton [x0,x1,x2] else empty
                                 ]
          in (enqueue (ok02 || ok03) oks, enqueue x0 xs, suffixes')
        nth3_3 (_,_,x) = x
        enqueue x xs = x : init xs

solve' :: String -> [String]
solve' str = sort . map reverse . toList . fst . suffixes (empty,"",0,empty) $ reverse str
  where suffixes :: (Set String, String, Int, Set Int) -> String -> (Set String, Set Int)
        suffixes (seen,prev,pos,processed) str =
          if pos `member` processed
            then (seen,processed) -- prune search of this branch - this state has already been explored
            else
              let (suffixes2,processed2) = case trySuffix 2 (seen,prev) str of
                                            Nothing ->
                                              (seen,processed)
                                            Just (seen',prev',str') ->
                                              suffixes (seen',prev',pos+2,processed) str'
                  (suffixes3,processed3) = case trySuffix 3 (seen,prev) str of
                                            Nothing ->
                                              (seen,processed2)
                                            Just (seen',prev',str') ->
                                              suffixes (seen',prev',pos+3,processed2) str'
              in (unions [suffixes2, suffixes3], unions [processed2, processed3, singleton pos])
        trySuffix :: Int -> (Set String, String) -> String -> Maybe (Set String, String, String)
        trySuffix n (seen,prev) str
          | str `shorterThan` (5 + n) = Nothing
          | otherwise          = let (suffix,rest) = splitAt n str
                                 in if suffix == prev
                                      then Nothing
                                      else Just (insert suffix seen, suffix, rest)

shorterThan [] n = n > 0
shorterThan xs n = shorterThan (tail xs) (n-1)

main :: IO ()
main = do
  word <- getLine
  let suffixes = solve word
  putStrLn $ show (length suffixes)
  mapM_ putStrLn suffixes

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

main = do
    s <- fmap (B.init . B.drop 5) B.getLine
    let all = solve s
    print $ S.size all
    B.putStrLn $ (B.pack "\n") `B.intercalate` S.toAscList all

solve s = all 0 d S.empty
  where d = dp s (B.length s - 4) [(False, True), (True, False), (False, False)]
        all i [] res = res
        all i ((v2,v3):xs) res = all (i + 1) xs res''
            where res'  = if v2 then (cur2 s i) `S.insert` res  else res
                  res'' = if v3 then (cur3 s i) `S.insert` res' else res'

dp s i res
  | i < 0 = drop (negate i - 1) res
  | otherwise = dp s (i - 1) ((v2, v3) : res)
  where v2 = snd (res !! 1) || (fst (res !! 1) && cur2 s i /= cur2 s (i + 2))
        v3 = fst (res !! 2) || (snd (res !! 2) && cur3 s i /= cur3 s (i + 3))

cur2 s a = B.take 2 . B.drop a $ s
cur3 s a = B.take 3 . B.drop a $ s

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

main = do
    s <- fmap (B.drop 5) B.getLine
    let all = solve s
    print $ S.size all
    B.putStrLn $ (B.pack "\n") `B.intercalate` S.toAscList all

solve s = all 0 d S.empty
  where d = dp s (B.length s - 4) [(False, True), (True, False), (False, False)]
        all i [] res = res
        all i ((v2,v3):xs) res = all (i + 1) xs res''
            where res'  = if v2 then (cur2 s i) `S.insert` res  else res
                  res'' = if v3 then (cur3 s i) `S.insert` res' else res'

dp s i res
  | i < 0 = drop (negate i - 1) res
  | otherwise = dp s (i - 1) ((v2, v3) : res)
  where v2 = snd (res !! 1) || (fst (res !! 1) && cur2 s i /= cur2 s (i + 2))
        v3 = fst (res !! 2) || (snd (res !! 2) && cur3 s i /= cur3 s (i + 3))

cur2 s a = B.take 2 . B.drop a $ s
cur3 s a = B.take 3 . B.drop a $ s

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

main = do
    s <- fmap (B.drop 5) B.getLine
    B.putStrLn s
    let all = solve s
    print $ S.size all
    B.putStrLn $ (B.pack "\n") `B.intercalate` S.toAscList all

solve s = all 0 d S.empty
  where d = dp s (B.length s - 4) [(False, True), (True, False), (False, False)]
        all i [] res = res
        all i ((v2,v3):xs) res = all (i + 1) xs res''
            where res'  = if v2 then (cur2 s i) `S.insert` res  else res
                  res'' = if v3 then (cur3 s i) `S.insert` res' else res'

dp s i res
  | i < 0 = drop (negate i - 1) res
  | otherwise = dp s (i - 1) ((v2, v3) : res)
  where v2 = snd (res !! 1) || (fst (res !! 1) && cur2 s i /= cur2 s (i + 2))
        v3 = fst (res !! 2) || (snd (res !! 2) && cur3 s i /= cur3 s (i + 3))

cur2 s a = B.take 2 . B.drop a $ s
cur3 s a = B.take 3 . B.drop a $ s

import qualified Data.IntMap as IM
import Data.IntMap ((!))
import Data.Ix (Ix, index, range)
import Data.List

main = do
    s <- getContents
    let strings = solve s
    print $ length strings
    mapM_ putStrLn strings

solve s = map head . group . sort $ strings
  where
    ms = IM.fromList $ zip [0..] (reverse s)
    n = IM.size ms

    f _ (_, m) | n-m <= 5 = False
    f _ (2, 1) = True
    f _ (3, 2) = True
    f _ (_, m) | m <= 2 = False
    f rec (prev, m) = rec (5-prev, m-prev) || (rec (prev, m-prev) && not (eq (m-2*prev) (m-prev)))

    eq a b = and $ zipWith (==) (map (ms!) [a+1..b]) (map (ms!) [b+1 .. 2*b-a])

    isGood = immemo f (2,0) (3,n-1)

    good2 = [i | i <- [1..n-1], isGood (2, i)]
    good3 = [i | i <- [2..n-1], isGood (3, i)]
    strings = [[ms!i, ms!(i-1)] | i <- good2] ++ [[ms!i, ms!(i-1), ms!(i-2)] | i <- good3]

immemo :: (Ix i) => ((i -> a) -> i -> a) -> i -> i -> i -> a
immemo f l r = memo
  where
    ix = index (l,r)
    memo = (IM.!) dp . ix
    dp = IM.fromList [(ix k, f memo k) | k <- range (l,r)]


Polycarp wrote on the board a string $$$s$$$ containing only lowercase Latin letters ('a'-'z'). This string is known for you and given in the input.After that, he erased some letters from the string $$$s$$$, and he rewrote the remaining letters in any order. As a result, he got some new string $$$t$$$. You have to find it with some additional information.Suppose that the string $$$t$$$ has length $$$m$$$ and the characters are numbered from left to right from $$$1$$$ to $$$m$$$. You are given a sequence of $$$m$$$ integers: $$$b_1, b_2, \ldots, b_m$$$, where $$$b_i$$$ is the sum of the distances $$$|i-j|$$$ from the index $$$i$$$ to all such indices $$$j$$$ that $$$t_j > t_i$$$ (consider that 'a'<'b'<...<'z'). In other words, to calculate $$$b_i$$$, Polycarp finds all such indices $$$j$$$ that the index $$$j$$$ contains a letter that is later in the alphabet than $$$t_i$$$ and sums all the values $$$|i-j|$$$.For example, if $$$t$$$ = "abzb", then:  since $$$t_1$$$='a', all other indices contain letters which are later in the alphabet, that is: $$$b_1=|1-2|+|1-3|+|1-4|=1+2+3=6$$$;  since $$$t_2$$$='b', only the index $$$j=3$$$ contains the letter, which is later in the alphabet, that is: $$$b_2=|2-3|=1$$$;  since $$$t_3$$$='z', then there are no indexes $$$j$$$ such that $$$t_j>t_i$$$, thus $$$b_3=0$$$;  since $$$t_4$$$='b', only the index $$$j=3$$$ contains the letter, which is later in the alphabet, that is: $$$b_4=|4-3|=1$$$. Thus, if $$$t$$$ = "abzb", then $$$b=[6,1,0,1]$$$.Given the string $$$s$$$ and the array $$$b$$$, find any possible string $$$t$$$ for which the following two requirements are fulfilled simultaneously:  $$$t$$$ is obtained from $$$s$$$ by erasing some letters (possibly zero) and then writing the rest in any order;  the array, constructed from the string $$$t$$$ according to the rules above, equals to the array $$$b$$$ specified in the input data.

The first line contains an integer $$$q$$$ ($$$1 \le q \le 100$$$) — the number of test cases in the test. Then $$$q$$$ test cases follow. Each test case consists of three lines:   the first line contains string $$$s$$$, which has a length from $$$1$$$ to $$$50$$$ and consists of lowercase English letters;  the second line contains positive integer $$$m$$$ ($$$1 \le m \le |s|$$$), where $$$|s|$$$ is the length of the string $$$s$$$, and $$$m$$$ is the length of the array $$$b$$$;  the third line contains the integers $$$b_1, b_2, \dots, b_m$$$ ($$$0 \le b_i \le 1225$$$).  It is guaranteed that in each test case an answer exists.

Output $$$q$$$ lines: the $$$k$$$-th of them should contain the answer (string $$$t$$$) to the $$$k$$$-th test case. It is guaranteed that an answer to each test case exists. If there are several answers, output any.

NoteIn the first test case, such strings $$$t$$$ are suitable: "aac', "aab".In the second test case, such trings $$$t$$$ are suitable: "a", "b", "c".In the third test case, only the string $$$t$$$ equals to "aba" is suitable, but the character 'b' can be from the second or third position.

import           Control.Monad
import           Control.Monad.Trans.State
import           Data.IntMap               (IntMap)
import qualified Data.IntMap               as IntMap
import           Data.List
import qualified Data.Map                  as Map

main :: IO()
main = do
  q <- read <$> getLine
  replicateM_ q solve

solve :: IO ()
solve = do
  s <- getLine
  m <- read <$> getLine :: IO Int
  b <- map read . words <$> getLine :: IO [Int]
  --print $ evalState (replicateM 1 $ calculateOrder m b) (0, [], IntMap.empty)
  let iMap = last $ evalState (replicateM 26 $ calculateOrder m b) (0, [], IntMap.empty)
  let wtf = IntMap.toList iMap
  let wtf3 = sortOn fst $ IntMap.toList $ foldr (\ (_, r) -> IntMap.alter alterM r) IntMap.empty wtf
  let wtf2 = reverse $ Map.toList $ foldr (Map.alter alterM) Map.empty s
  let wtf4 = IntMap.fromList $ cf wtf3 wtf2
  let wtf5 = map ((\ r -> wtf4 IntMap.! r). snd) wtf
  putStrLn wtf5
  return ()
  where
    alterM :: Maybe Int -> Maybe Int
    alterM Nothing  = Just 1
    alterM (Just k) = Just $ k+1
    cf :: [(Int, Int)] -> [(Char, Int)] -> [(Int, Char)]
    cf [] _ = []
    cf wtf3@((wf, ws):tf3) ((wtf, wts):f2) | ws <= wts = (wf, wtf) : cf tf3 f2
                                           | otherwise = cf wtf3 f2

calculateOrder :: Int -> [Int] -> State (Int, [Int], IntMap Int) (IntMap Int)
calculateOrder m b = do
  (it, l, iMap) <- get
  let diff = map (\ i -> sum (map (\ e -> abs $ i - e) l)) [1..m]
  let match = filter (\ x -> x /= -1) $ zipWith3 (\ e d i -> if e == d then i else -1) b diff [1..]
  let newM = foldr (\ i -> if i == -1 then id else IntMap.insertWith (flip const) i it) iMap match
  put (it + 1, match `union` l, newM)
  return newM

import Control.Monad
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.List (group)
fullUpdate f b = helper (Map.keys b) b
  where helper [] b = b
        helper (a:t) b = helper t (Map.updateWithKey f a b)

fullInsert keys b val = helper keys b
  where helper [] b = b
        helper (a:t) b = helper t (Map.insert a val b)

deleteAfter key map = Map.filterWithKey (\k _ -> k < key) map

solve (t, b) =
  let
    iter t b new
      | Map.size b == 0 = Map.elems new
      | otherwise   =
        let
          zeros = filter (\(_,b) -> b == 0) (Map.assocs b)
          zeroInd = map fst zeros
          maxT = fst.head $ filter (\(_, i) -> i >= length zeroInd) (Map.toDescList t)
          newB = Map.mapWithKey (\k a -> a - sum (map (\x -> abs (k - x)) zeroInd)) (fullUpdate (\i a -> if elem i (zeroInd) then Nothing else Just a) b)
        in
          iter (deleteAfter maxT t) newB (fullInsert zeroInd new maxT)
  in
    iter t b Map.empty

getCase = do
  t <- Map.fromListWith (+) . (flip zip) (repeat 1) <$> getLine
  n <-getLine
  bStr <- getLine
  let b = Map.fromList $ zip [1..] ((map read) $ words bStr)
  return (t, b)

main = do
  n <- read <$> getLine
  inp <- replicateM n getCase
  mapM_ putStrLn (map solve inp)

import           Control.Monad
import           Control.Monad.Trans.State
import           Data.IntMap               (IntMap)
import qualified Data.IntMap               as IntMap
import           Data.List
import qualified Data.Map                  as Map

main :: IO()
main = do
  q <- read <$> getLine
  replicateM_ q solve

solve :: IO ()
solve = do
  s <- getLine
  m <- read <$> getLine :: IO Int
  b <- map read . words <$> getLine :: IO [Int]
  let iMap = last $ evalState (replicateM 26 $ calculateOrder m b) (0, [], IntMap.empty)
  let wtf = IntMap.toList iMap
  let wtf3 = sortOn fst $ IntMap.toList $ foldr (\ (_, r) -> IntMap.alter alterM r) IntMap.empty wtf
  let wtf2 = reverse $ Map.toList $ foldr (Map.alter alterM) Map.empty s
  let wtf4 = IntMap.fromList $ cf wtf3 wtf2
  let wtf5 = map ((\ r -> wtf4 IntMap.! r). snd) wtf
  putStrLn $ unwords $ map (:[]) wtf5
  return ()
  where
    alterM :: Maybe Int -> Maybe Int
    alterM Nothing  = Just 1
    alterM (Just k) = Just $ k+1
    cf :: [(Int, Int)] -> [(Char, Int)] -> [(Int, Char)]
    cf [] _ = []
    cf wtf3@((wf, ws):tf3) ((wtf, wts):f2) | ws <= wts = (wf, wtf) : cf tf3 f2
                                           | otherwise = cf wtf3 f2

calculateOrder :: Int -> [Int] -> State (Int, [Int], IntMap Int) (IntMap Int)
calculateOrder m b = do
  (it, l, iMap) <- get
  let diff = map (\ i -> sum (map (\ e -> abs $ i - e) l)) [1..m]
  let match = zipWith3 (\ e d i -> if e == d then i else -1) b diff [1..]
  let newM = foldr (\ i -> if i == -1 then id else IntMap.insertWith (flip const) i it) iMap match
  put (it + 1, match, newM)
  return newM


A correct expression of the form a+b=c was written; a, b and c are non-negative integers without leading zeros. In this expression, the plus and equally signs were lost. The task is to restore the expression. In other words, one character '+' and one character '=' should be inserted into given sequence of digits so that:   character'+' is placed on the left of character '=',  characters '+' and '=' split the sequence into three non-empty subsequences consisting of digits (let's call the left part a, the middle part — b and the right part — c),  all the three parts a, b and c do not contain leading zeros,  it is true that a+b=c. It is guaranteed that in given tests answer always exists.

The first line contains a non-empty string consisting of digits. The length of the string does not exceed 106.

Output the restored expression. If there are several solutions, you can print any of them. Note that the answer at first should contain two terms (divided with symbol '+'), and then the result of their addition, before which symbol'=' should be.  Do not separate numbers and operation signs with spaces. Strictly follow the output format given in the examples. If you remove symbol '+' and symbol '=' from answer string you should get a string, same as string from the input data.

{-# OPTIONS_GHC -O3 #-}
{-# LANGUAGE ViewPatterns, ScopedTypeVariables, BangPatterns #-}

import qualified Data.ByteString as B (getLine)
import qualified Data.ByteString.Char8 as C (unpack, reverse, dropWhile)
import qualified Data.Char as C (isSpace, digitToInt)
import qualified Data.List as L (zip4)
import qualified Data.Int as I (Int64)
import qualified Data.Array.IArray as A (listArray, (!), elems)
import qualified Data.Array.Unboxed as A (UArray)

pp = [1000000007, 1000000009] :: [I.Int64]

rstrip = C.reverse . C.dropWhile C.isSpace . C.reverse

main = do
    (map (fromIntegral . C.digitToInt) . C.unpack . rstrip -> !xs) <- B.getLine
    let !n = length xs
        !pw = map (\p -> A.listArray (0, n) $ iterate (\x -> x * 10 `mod` p) 1) pp :: [A.UArray Int I.Int64]
        !dxs = zipWith (\p (A.elems -> w) -> zipWith (\x y -> x * y `mod` p) xs (tail $ reverse w)) pp pw
        !xxs = A.listArray (0, n - 1) xs :: A.UArray Int I.Int64
        !xl = map (\p -> A.listArray (0, n) $ scanl (\x y -> (x * 10 + y) `mod` p) 0 xs) pp :: [A.UArray Int I.Int64]
        !xr = zipWith3 (\p d l -> A.listArray (0, n) $ scanl (\x y -> ((x - y) `mod` p + p) `mod` p) (l A.! n) d) pp dxs xl :: [A.UArray Int I.Int64]
        test a b | a < 1 || b < 1 || c < 1 || (xxs A.! a == 0 && b /= 1) || (xxs A.! (a + b) == 0 && c /= 1) = False
                 | not (max a b == c || max a b == c - 1) = False
                 | otherwise = all (\(p, w, l, r) -> ((l A.! a + l A.! (a + b)) `mod` p - l A.! a * w A.! b `mod` p + p) `mod` p == r A.! (a + b)) (L.zip4 pp pw xl xr)
            where c = n - a - b
        run (x:rs) | test x (n - x - x) = (x, n - x - x) | test x (n - x - x - 1) = (x, n - x - x - 1) | test x ((n - x) `div` 2) = (x, (n - x) `div` 2)
                   | otherwise = run rs
        prun (a, b) = concat (map show (take a xs)) ++ "+" ++ concat (map show (drop a $ take (a + b) xs)) ++ "=" ++ concat (map show (drop (a + b) xs))
    putStrLn $ prun $ run [1..n `div` 2]

{-# OPTIONS_GHC -O3 #-}
{-# LANGUAGE ViewPatterns, ScopedTypeVariables, BangPatterns #-}

import qualified Data.ByteString as B (getLine)
import qualified Data.ByteString.Char8 as C (unpack, reverse, dropWhile)
import qualified Data.Char as C (isSpace, digitToInt)
import qualified Data.List as L (zip4)
import qualified Data.Int as I (Int64)
import qualified Data.Array.IArray as A (listArray, (!), elems)
import qualified Data.Array.Unboxed as A (UArray)

pp = [1000000007, 1000000009] :: [I.Int64]

rstrip = C.reverse . C.dropWhile C.isSpace . C.reverse

main = do
    (map (fromIntegral . C.digitToInt) . C.unpack . rstrip -> !xs) <- B.getLine
    let !n = length xs
        !pw = map (\p -> A.listArray (0, n) $ iterate (\x -> x * 10 `mod` p) 1) pp :: [A.UArray Int I.Int64]
        !dxs = zipWith (\p (A.elems -> w) -> zipWith (\x y -> x * y `mod` p) xs (tail $ reverse w)) pp pw
        !xxs = A.listArray (0, n - 1) xs :: A.UArray Int I.Int64
        !xl = map (\p -> A.listArray (0, n) $ scanl (\x y -> (x * 10 + y) `mod` p) 0 xs) pp :: [A.UArray Int I.Int64]
        !xr = zipWith3 (\p d l -> A.listArray (0, n) $ scanl (\x y -> ((x - y) `mod` p + p) `mod` p) (l A.! n) d) pp dxs xl :: [A.UArray Int I.Int64]
        test a b | a < 1 || b < 1 || c < 1 || (xxs A.! a == 0 && b /= 1) || (xxs A.! (a + b) == 0 && c /= 1) = False
                 | otherwise = all (\(p, w, l, r) -> ((l A.! a + l A.! (a + b)) `mod` p - l A.! a * w A.! b `mod` p + p) `mod` p == r A.! (a + b)) (L.zip4 pp pw xl xr)
            where c = n - a - b
        run (x:rs) | test x (n - x - x) = (x, n - x - x) | test x (n - x - x - 1) = (x, n - x - x - 1) | test x ((n - x) `div` 2) = (x, (n - x) `div` 2)
                   | otherwise = run rs
        prun (a, b) = concat (map show (take a xs)) ++ "+" ++ concat (map show (drop a $ take (a + b) xs)) ++ "=" ++ concat (map show (drop (a + b) xs))
    putStrLn $ prun $ run [1..n `div` 2]


Ichihime is the current priestess of the Mahjong Soul Temple. She claims to be human, despite her cat ears.These days the temple is holding a math contest. Usually, Ichihime lacks interest in these things, but this time the prize for the winner is her favorite — cookies. Ichihime decides to attend the contest. Now she is solving the following problem. You are given four positive integers $$$a$$$, $$$b$$$, $$$c$$$, $$$d$$$, such that $$$a \leq b \leq c \leq d$$$. Your task is to find three integers $$$x$$$, $$$y$$$, $$$z$$$, satisfying the following conditions: $$$a \leq x \leq b$$$. $$$b \leq y \leq c$$$. $$$c \leq z \leq d$$$. There exists a triangle with a positive non-zero area and the lengths of its three sides are $$$x$$$, $$$y$$$, and $$$z$$$.Ichihime desires to get the cookie, but the problem seems too hard for her. Can you help her?

The first line contains a single integer $$$t$$$ ($$$1 \leq t \leq 1000$$$)  — the number of test cases. The next $$$t$$$ lines describe test cases. Each test case is given as four space-separated integers $$$a$$$, $$$b$$$, $$$c$$$, $$$d$$$ ($$$1 \leq a \leq b \leq c \leq d \leq 10^9$$$).

For each test case, print three integers $$$x$$$, $$$y$$$, $$$z$$$  — the integers you found satisfying the conditions given in the statement. It is guaranteed that the answer always exists. If there are multiple answers, print any.

NoteOne of the possible solutions to the first test case:One of the possible solutions to the second test case:

import Control.Arrow

main = interact $
  lines >>> drop 1
  >>> map (words >>> map read)
  >>> process
  >>> map (map show >>> unwords) >>> unlines

process :: [[Int]] -> [[Int]]
process [] = []
process ([_,b,c,_]:ps) = [b,c,c] : process ps

module Main where

import Control.Monad
import Data.List

getStrList :: IO [String]
getStrList = words <$> getLine

getIntList :: IO [Int]
getIntList = map read <$> getStrList

printStrList :: [String] -> IO ()
printStrList = putStrLn . intercalate " "

printList :: (Show a) => [a] -> IO ()
printList = printStrList . map show

main :: IO ()
main = do
    t <- readLn
    replicateM_ t $ do
        [a, b, c, d] <- getIntList
        printList [b, c, c]

main = getLine >>= test.read
test 0 = return ()
test i = do
    (a:b:c:d:_) <- map read . words <$> getLine :: IO [Integer]
    putStrLn $ unwords $ map show [b, c, c]
    test (i - 1)

import Control.Monad
main :: IO ()
main = do
    n <- readLn
    replicateM_ n routine

routine :: IO ()
routine = do
    [a,b,c,d] <- (map (read ::String -> Int).words) <$> getLine
    putStrLn $ (unwords.map show) [b,c,c]

solve :: [String] -> [String]
solve [a, b, c, d] = [b, c, c]

io :: String -> String
io s = unlines $ map (unwords . solve . words) $ drop 1 (lines s)

main :: IO ()
main = do
  interact io

import Control.Monad (forM_)

-- a <= x <= b <= y <= c <= z <= d
-- x + y > z

solve [a,b,c,d] = show b ++ " " ++ show c ++ " " ++ show c where

main = do
	t <- fmap read getLine
	forM_ [1..t] $ \i -> do
		xs <- fmap (map read.words) getLine :: IO [Int]
		putStrLn (solve xs)

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

process [a,b,c,d] = do
			putStrLn $ intercalate " " $ map show [b,c,c]

main = do
		n<- read <$> getLine ::IO Int
		a<-map(map read) <$> map words <$> replicateM n getLine ::IO [[Int]]
		mapM_ process a

solve :: Integer -> Integer -> Integer -> Integer -> (Integer, Integer, Integer)
solve _ b c _ = (b, c, c)

parse :: String -> String
parse input = (show x) ++ " " ++ (show y) ++ " " ++ (show z)
  where [a, b, c, d] = map (\r -> read r :: Integer) $ words input
        (x, y, z) = solve a b c d

main :: IO ()
main = interact (unlines . map parse . tail . lines)


A boy Bob likes to draw. Not long ago he bought a rectangular graph (checked) sheet with n rows and m columns. Bob shaded some of the squares on the sheet. Having seen his masterpiece, he decided to share it with his elder brother, who lives in Flatland. Now Bob has to send his picture by post, but because of the world economic crisis and high oil prices, he wants to send his creation, but to spend as little money as possible. For each sent square of paper (no matter whether it is shaded or not) Bob has to pay 3.14 burles. Please, help Bob cut out of his masterpiece a rectangle of the minimum cost, that will contain all the shaded squares. The rectangle's sides should be parallel to the sheet's sides.

The first line of the input data contains numbers n and m (1 ≤ n, m ≤ 50), n — amount of lines, and m — amount of columns on Bob's sheet. The following n lines contain m characters each. Character «.» stands for a non-shaded square on the sheet, and «*» — for a shaded square. It is guaranteed that Bob has shaded at least one square.

Output the required rectangle of the minimum cost. Study the output data in the sample tests to understand the output format better.

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

import Control.Monad

import Data.IORef
import System.IO.Unsafe

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

cut a b = drop a . take (b+1)

main = do n <- cin :: IO Int
          m <- cin :: IO Int
          css <- replicateM n cin :: IO [String]
          let painted x y = css!!y!!x == '*'
              colCheck x = any (painted x) [0..n-1]
              rowCheck y = any (`painted` y) [0..m-1]
              get f xs = head $ filter f xs
              left   = get colCheck [0..]
              right  = get colCheck $ reverse [0..m-1]
              top    = get rowCheck [0..]
              bottom = get rowCheck $ reverse [0..n-1]
          mapM_ putStrLn . map (cut left right) $ cut top bottom css

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

import Control.Monad

import Data.IORef
import System.IO.Unsafe

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

cut a b = drop a . take b

main = do n <- cin :: IO Int
          m <- cin :: IO Int
          css <- replicateM n cin :: IO [String]
          let f x y = css!!y!!x == '*'
              s = subtract
              left = until (\x -> any (f x) [0..n-1]) (+1) 0
              right = until (\x -> any (f x) [0..n-1]) (s 1) (m-1)
              top = until (\y -> any (`f` y) [0..m-1]) (+1) 0
              bottom = until (\y -> any (`f` y) [0..m-1]) (s 1) (n-1)
              css' = cut top (bottom+1) css
          mapM_ putStrLn $ map (cut left (right+1)) css'

main = do
	a <-getLine
	c <-getContents
	putStrLn $ unlines $ solve (lines c)

cutterH [] = []
cutterH (s:ss) = if not ('*' `elem` s) then cutter ss
	            else s:ss

cutterT [] = []
cutterT (k) = if not ('*' `elem` s) then cutter ss
	            else k
	            where s = last k
	                  ss = init k

cutter s = cutterT $ cutterH s

transpose::[String]->[String]
transpose s | null (head s) = []
transpose s = [map head s] ++ (transpose (map tail s))

solve s = transpose res2
	  where res1 = cutter s
	        res2 = cutter $transpose res1

import List

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

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

dropNoStart [] = []
dropNoStart (x:xs) | elem '*' x = x:xs
                   | True       = dropNoStart xs

main = do
    s <- getLine
    let n:m:_ = un s
    l <- getLines n
    let l1 = dropNoStart l
        l2 = reverse $ dropNoStart $ reverse l1
        l3 = dropNoStart $ transpose l2
        l4 = reverse $ dropNoStart $ reverse l3
        l5 = transpose l4
    mapM_ putStrLn $ l5

import Data.Array
import Control.Monad (forM_,replicateM)
import Text.Printf

hasStar xs = any (=='*') xs

solve arr =
  let ((rmin,cmin),(rmax,cmax)) = bounds arr
      row r = [ arr ! (r,c) | c <- [cmin..cmax] ]
      col c = [ arr ! (r,c) | r <- [rmin..rmax] ]
      rlo -- first row which has a "*"
          = head [ r | r <- [rmin..rmax], hasStar (row r) ]
      rhi -- last row which has a "*"
          = head [ r | r <- [rmax,rmax-1..rmin], hasStar (row r) ]
      clo -- first column which has a "*"
          = head [ c | c <- [cmin..cmax], hasStar (col c) ]
      chi -- last column which has a "*"
          = head [ c | c <- [cmax,cmax-1..cmin], hasStar (col c) ]
  in (rlo,rhi,clo,chi)

(-->) = flip fmap

main = do
  (n:m:_) <- getLine --> words --> map read
  lines <- replicateM n getLine
  let arr = listArray ((1,1),(n,m)) (concat lines)
  let (rlo,rhi,clo,chi) = solve arr
  forM_ [rlo..rhi] $ \r -> do
    let s = [ arr ! (r,c) | c <- [clo..chi] ]
    putStrLn s

import Array (Array, (!), array, bounds)
import Monad (liftM)

findBounds :: Array (Int, Int) Char -> ((Int, Int), (Int, Int))
findBounds array  =  ((minI, minJ), (maxI, maxJ))
  where
    ((i0, j0), (iN, jN))  =  bounds array
    rows  =  [i | i <- [i0 .. iN], any (== '*') [array ! (i, j) | j <- [j0 .. jN]]]
    cols  =  [j | j <- [j0 .. jN], any (== '*') [array ! (i, j) | i <- [i0 .. iN]]]
    (minI, maxI)  =  (minimum rows, maximum rows)
    (minJ, maxJ)  =  (minimum cols, maximum cols)

main :: IO ()
main  =  do
    [n, m]  <-  liftM (map read . words) getLine
    lines'  <-  liftM (take n . lines) getContents
    let array'  =  array ((1,1), (n,m)) [((i,j), lines' !! (i-1) !! (j-1)) | i <- [1..n], j <- [1..m]]
    let ((minI, minJ), (maxI, maxJ))  =  findBounds array'
    mapM_ (\i -> putStrLn [array' ! (i, j) | j <- [minJ .. maxJ]]) [minI .. maxI]

import List
import Control.Monad
import Control.Applicative

solve = twice (map reverse.cut) . twice (reverse.dropWhile (all (=='.')))
        where twice f = (f.f)
              cut rows | all ((=='.').head) rows = cut $ map tail rows
                       | otherwise = rows

main = do
    [n, _] <- map read . words <$> getLine
    (replicateM n getLine) >>= (mapM_ putStrLn . solve)

import List
import Control.Monad
import Control.Applicative

solve = twice (rev1.cut1) . twice (rev2.cut2)
    where twice f = (f.f)
          rev1 = map reverse
          cut1 rows | all ((=='.').head) rows = cut1 $ map tail rows
                    | otherwise = rows
          rev2 = reverse
          cut2 rows | all (=='.') $ head rows = cut2 $ tail rows
                    | otherwise = rows

main = do
    [n, m] <- map read . words <$> getLine
    rows <- replicateM n getLine
    mapM_ putStrLn $ solve rows

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

dots x = all (=='.') x

main = do
		[n,m]<- map read <$> words <$>getLine ::IO [Int]
		x<-replicateM n getLine::IO [String]
		let y=transpose $ reverse $ dropWhile (dots) $ reverse $ dropWhile (dots) $ transpose $ reverse  $ dropWhile (dots) $ reverse $ dropWhile (dots) x
		mapM_ putStrLn y

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

findLeft x = length. takeWhile (== '.') $ x

main :: IO ()
main = do
	line <- getLine
	let
		[m, n] = map (\x -> read x :: Int). words$ line
	arr' <- getContents
	let
		arr = lines arr'
		tarr = transpose arr
		left =  minimum. map findLeft $ arr
		top  = minimum. map findLeft $ tarr
		right = n - (minimum. map findLeft. map reverse $arr)
		bot =  m -  (minimum. map findLeft. map reverse $ tarr)
--	mapM_ print arr
--	putStrLn ""
--	mapM_ print tarr
--	putStrLn ""
--	putStrLn $ "left  = " ++ show left
--	putStrLn $ "top   = " ++ show top
--	putStrLn $ "right = " ++ show right
--	putStrLn $ "bot   = " ++ show bot
--	putStrLn ""
	mapM_ putStrLn. map (drop left). map (take right). drop top. take bot $ arr

main = do
	a <-getLine
	c <-getContents
	putStrLn $ unlines $ solve (lines c)

cutter [] = []
cutter (s:ss) = if not ('*' `elem` s) then cutter ss
	            else [s]++cutter ss

transpose::[String]->[String]
transpose s | null (head s) = []
transpose s = [map head s] ++ (transpose (map tail s))

solve s = transpose res2
	  where res1 = cutter s
	        res2 = cutter $transpose res1

import List
import Control.Monad
import Control.Applicative

solve rows = (reverseCols.cutCols.reverseCols.cutCols.filter notEmpty) rows
    where reverseCols = map reverse
          cutCols rows | all ((=='.').head) rows = cutCols $ map tail rows
                       | otherwise = rows
          notEmpty = any (=='*')

main = do
    [n, m] <- map read . words <$> getLine
    rows <- replicateM n getLine
    mapM_ putStrLn $ solve rows

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

findLeft x = length. takeWhile (== '.') $ x

main :: IO ()
main = do
	line <- getLine
	let
		[m, n] = map (\x -> read x :: Int). words$ line
	arr' <- getContents
	let
		arr = lines arr'
		tarr = transpose arr
		left =  minimum. map findLeft $ arr
		top  = minimum. map findLeft $ tarr
		right = n - (minimum. map findLeft. map reverse $arr)
		bot =  m -  (minimum. map findLeft. map reverse $ tarr)
--	mapM_ print arr
--	putStrLn ""
--	mapM_ print tarr
--	putStrLn ""
--	putStrLn $ "left  = " ++ show left
--	putStrLn $ "top   = " ++ show top
--	putStrLn $ "right = " ++ show right
--	putStrLn $ "bot   = " ++ show bot
--	putStrLn ""
	mapM_ print. map (drop left). map (take right). drop top. take bot $ arr