On a plane are n points (xi, yi) with integer coordinates between 0 and 106. The distance between the two points with numbers a and b is said to be the following value:  (the distance calculated by such formula is called Manhattan distance).We call a hamiltonian path to be some permutation pi of numbers from 1 to n. We say that the length of this path is value .Find some hamiltonian path with a length of no more than 25 × 108. Note that you do not have to minimize the path length.

The first line contains integer n (1 ≤ n ≤ 106). The i + 1-th line contains the coordinates of the i-th point: xi and yi (0 ≤ xi, yi ≤ 106). It is guaranteed that no two points coincide.

Print the permutation of numbers pi from 1 to n — the sought Hamiltonian path. The permutation must meet the inequality . If there are multiple possible answers, print any of them. It is guaranteed that the answer exists.

NoteIn the sample test the total distance is:(|5 - 3| + |0 - 4|) + (|3 - 0| + |4 - 7|) + (|0 - 8| + |7 - 10|) + (|8 - 9| + |10 - 12|) = 2 + 4 + 3 + 3 + 8 + 3 + 1 + 2 = 26

{-# OPTIONS_GHC -O2 -optc-O2 #-}
import Prelude hiding (getLine)
import Data.Function (on)
import Control.Applicative ((<$>))
import Control.Monad (replicateM)
import Data.ByteString (ByteString, getLine)
import Data.List (unfoldr, sort)
import qualified Data.ByteString.Char8 as B
import Data.Array (accumArray, elems)

parse :: ByteString -> [Int]
parse = unfoldr $ B.readInt . B.dropWhile (== ' ')

solve :: [[Int]] -> [Int]
solve = map snd
        . concat
        . zipWith ($) (cycle [sort, reverse . sort])
        . elems
        . accumArray (flip (:)) [] (0 :: Int, 1000 :: Int)
        . zipWith (\i (x:y:_) -> (x `div` 1000, (y, i))) [1..]

main = do
    [n] <- parse <$> getLine
    replicateM n getLine >>= putStrLn . unwords . map show . solve . map parse


An n × n square matrix is special, if:  it is binary, that is, each cell contains either a 0, or a 1;  the number of ones in each row and column equals 2. You are given n and the first m rows of the matrix. Print the number of special n × n matrices, such that the first m rows coincide with the given ones.As the required value can be rather large, print the remainder after dividing the value by the given number mod.

The first line of the input contains three integers n, m, mod (2 ≤ n ≤ 500, 0 ≤ m ≤ n, 2 ≤ mod ≤ 109). Then m lines follow, each of them contains n characters — the first rows of the required special matrices. Each of these lines contains exactly two characters '1', the rest characters are '0'. Each column of the given m × n table contains at most two numbers one.

Print the remainder after dividing the required value by number mod.

NoteFor the first test the required matrices are: 011101110011110101In the second test the required matrix is already fully given, so the answer is 1.

import Data.Char
import qualified Data.List as List

addMod :: Int -> Int -> Int -> Int
addMod mm a b
    | a + b < mm = a + b
    | otherwise = a + b - mm

bits :: Int -> [Int]
bits 0 = []
bits n = n `mod` 2 : bits (n `div` 2)

mulMod :: Int -> Int -> Int -> Int
mulMod mm a b = let step :: (Int, Int) -> Int -> (Int, Int)
                    step (sum, pow) 0 = (sum, addMod mm pow pow)
                    step (sum, pow) 1 = (addMod mm sum pow, addMod mm pow pow)
                 in fst $ foldl step (0, a) $ bits b

choose :: Int -> Int -> Int -> Int
choose mm n 0 = 1 `mod` mm
choose mm n 1 = n `mod` mm
choose mm n 2 = n * (n - 1) `div` 2 `mod` mm

dynamic :: Int -> Int -> [Int]
dynamic mm 0 = [1 `mod` mm]
dynamic mm x = let v = dynamic mm (x - 1)
                   aa = 0 : 0 : zipWith (\p y -> mulMod mm p $ choose mm (y + 2) 2) (init v) [0 .. ]
                   ab = 0 : zipWith (\p y -> let cy = choose mm (y + 1) 1
                                                 cz = choose mm (2 * (x - y - 1)) 1
                                              in mulMod mm p $ mulMod mm cy cz)
                        v [0 .. ]
                   bb = (zipWith (\p y -> mulMod mm p $ choose mm (2 * (x - y)) 2) v [0 .. ]) ++ [0]
                in zipWith (addMod mm) aa $ zipWith (addMod mm) ab bb

main = do
    [n, m, mm] <- getLine >>= (return . map read . words)
    input <- getContents >>= (return . map (map (\x -> ord x - ord '0')) . lines)
    let v = List.foldl' (zipWith (-)) (replicate n 2) input
        two = length $ filter (== 2) v
        ret = dynamic mm (n - m) !! two
    print ret

import Data.Char
import qualified Data.List as List

addMod :: Int -> Int -> Int -> Int
addMod mm a b
    | a + b < mm = a + b
    | otherwise = a + b - mm

mulMod :: Int -> Int -> Int -> Int
mulMod mm a b = a * b `mod` mm

choose :: Int -> Int -> Int -> Int
choose mm n 0 = 1 `mod` mm
choose mm n 1 = n `mod` mm
choose mm n 2 = n * (n - 1) `div` 2 `mod` mm

dynamic :: Int -> Int -> [Int]
dynamic mm 0 = [1 `mod` mm]
dynamic mm x = let v = dynamic mm (x - 1)
                   aa = 0 : 0 : zipWith (\p y -> mulMod mm p $ choose mm (y + 2) 2) (init v) [0 .. ]
                   ab = 0 : zipWith (\p y -> let cy = choose mm (y + 1) 1
                                                 cz = choose mm (2 * (x - y - 1)) 1
                                              in mulMod mm p $ mulMod mm cy cz)
                        v [0 .. ]
                   bb = (zipWith (\p y -> mulMod mm p $ choose mm (2 * (x - y)) 2) v [0 .. ]) ++ [0]
                in zipWith (addMod mm) aa $ zipWith (addMod mm) ab bb

main = do
    [n, m, mm] <- getLine >>= (return . map read . words)
    input <- getContents >>= (return . map (map (\x -> ord x - ord '0')) . lines)
    let v = List.foldl' (zipWith (-)) (replicate n 2) input
        two = length $ filter (== 2) v
        ret = dynamic mm (n - m) !! two
    print (maxBound :: Int)
    print ret

import Data.Char
import qualified Data.List as List

addMod :: Int -> Int -> Int -> Int
addMod mm a b
    | a + b < mm = a + b
    | otherwise = a + b - mm

mulMod :: Int -> Int -> Int -> Int
mulMod mm a b = a * b `mod` mm

choose :: Int -> Int -> Int -> Int
choose mm n 0 = 1 `mod` mm
choose mm n 1 = n `mod` mm
choose mm n 2 = n * (n - 1) `div` 2 `mod` mm

dynamic :: Int -> Int -> [Int]
dynamic mm 0 = [1 `mod` mm]
dynamic mm x = let v = dynamic mm (x - 1)
                   aa = 0 : 0 : zipWith (\p y -> mulMod mm p $ choose mm (y + 2) 2) (init v) [0 .. ]
                   ab = 0 : zipWith (\p y -> let cy = choose mm (y + 1) 1
                                                 cz = choose mm (2 * (x - y - 1)) 1
                                              in mulMod mm p $ mulMod mm cy cz)
                        v [0 .. ]
                   bb = (zipWith (\p y -> mulMod mm p $ choose mm (2 * (x - y)) 2) v [0 .. ]) ++ [0]
                in zipWith (addMod mm) aa $ zipWith (addMod mm) ab bb

main = do
    [n, m, mm] <- getLine >>= (return . map read . words)
    input <- getContents >>= (return . map (map (\x -> ord x - ord '0')) . lines)
    let v = List.foldl' (zipWith (-)) (replicate n 2) input
        two = length $ filter (== 2) v
        ret = dynamic mm (n - m) !! two
    print ret


Vasya has started watching football games. He has learned that for some fouls the players receive yellow cards, and for some fouls they receive red cards. A player who receives the second yellow card automatically receives a red card.Vasya is watching a recorded football match now and makes notes of all the fouls that he would give a card for. Help Vasya determine all the moments in time when players would be given red cards if Vasya were the judge. For each player, Vasya wants to know only the first moment of time when he would receive a red card from Vasya.

The first line contains the name of the team playing at home. The second line contains the name of the team playing away. Both lines are not empty. The lengths of both lines do not exceed 20. Each line contains only of large English letters. The names of the teams are distinct. Next follows number n (1 ≤ n ≤ 90) — the number of fouls.  Each of the following n lines contains information about a foul in the following form:    first goes number t (1 ≤ t ≤ 90) — the minute when the foul occurs;  then goes letter "h" or letter "a" — if the letter is "h", then the card was given to a home team player, otherwise the card was given to an away team player;  then goes the player's number m (1 ≤ m ≤ 99);  then goes letter "y" or letter "r" — if the letter is "y", that means that the yellow card was given, otherwise the red card was given.  The players from different teams can have the same number. The players within one team have distinct numbers. The fouls go chronologically, no two fouls happened at the same minute.

For each event when a player received his first red card in a chronological order print a string containing the following information:   The name of the team to which the player belongs;  the player's number in his team;  the minute when he received the card.  If no player received a card, then you do not need to print anything. It is possible case that the program will not print anything to the output (if there were no red cards).

import Data.Function (on)
import Data.List (foldl', sortBy)
import qualified Data.Map as M

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

solve :: [String] -> [String]
solve (home:away:_:xs) = map format $ sortBy (compare `on` snd) $ M.toList
                       $ M.filter isRedCard $ foldl' go M.empty xs
  where go m x = M.insertWith' f (team, number) (card, read time :: Integer) m
          where [time, team, number, card] = words x
                f (_, t) ("y", _) = ("r", t); f _ p@("r", _) = p; f n _ = n
        format ((team, number), (_, time)) = unwords [ teamName team, number, show time ]
        teamName "h" = home; teamName _ = away
        isRedCard = (=="r") . fst
solve _ = undefined

import Data.List (foldl', sortBy)
import qualified Data.Map as M
import Data.Function (on)

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

solve :: [String] -> [String]
solve (home:away:_:xs) = map format $ sortBy (compare `on` snd) $ M.toList
                       $ M.filter ((=="r") . fst) $ foldl' go M.empty xs
  where go m x = M.insertWith' f (team, number) (card, read time :: Integer) m
          where [time, team, number, card] = words x
                f (_, t) ("y", _) = ("r", t)
                f _ p@("r", _) = p
                f n _ = n
        format ((team, number), (_, time)) = unwords [ if team == "h" then home else away, number, show time ]
solve _ = undefined

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, TupleSections, OverloadedStrings #-}
import Control.Applicative
import Control.Exception hiding (mask)
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST (runSTUArray, runSTArray)
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Function
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.IntMap as IM
import qualified Data.Set as S
import qualified Data.IntSet as IS
import Data.STRef
import GHC.Arr (Array, STArray, Ix(..))
import Debug.Trace

bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs=case B.readInt bs of{Just(n,_)->n;_->error$"readInt error : bs = "++show bs;}
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep n f=foldr((>>).f)(return())[0..n-1]
rev n f=foldr((>>).f.negate)(return())[1-n..0]
for :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
for a b f=foldr((>>).f)(return())[a..b]
{-# INLINE rep #-}
{-# INLINE rev #-}
{-# INLINE for #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
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
  hName <- getLine
  aName <- getLine
  _n <- getLine
  ttpcs <- sort.parse.words <$> getContents
  case solve hName aName ttpcs of
    [] -> return ()
    res -> putStr $ unlines res

type Time = Int
data Team = H | A deriving (Eq,Ord)
type Player = Int
data Color = Y | R deriving (Eq,Ord)

parse :: [String] -> [(Time,Team,Player,Color)]
parse (time:t:p:c:rest) = (read time, bool H A (t=="h"),read p,bool Y R (c=="y")) : parse rest
parse _ = []

solve :: String -> String -> [(Time,Team,Player,Color)] -> [String]
solve hName aName ttpcs = go [] [] ttpcs
   where
     showTeam H = hName
     showTeam A = aName
     isLive (t0,p0) (_,t,p,_) = t0/=t || p0/=p
     go hps aps ((time,team,player,color):rest)
       | color == R = res : go hps aps (filter (isLive (team,player))rest)
       | team == H, elem player hps = res : go hps aps (filter (isLive(team,player))rest)
       | team == H = go (player:hps) aps rest
       | team == A, elem player aps = res : go hps aps (filter (isLive(team,player))rest)
       | team == A = go hps (player:aps) rest
       | otherwise = undefined
      where
        res = unwords[showTeam team, show player, show time]
     go _ _ _ = []

import Control.Monad
import qualified Data.Map as M
import Data.List (sort)

main :: IO ()
main = do
  home <- getLine
  away <- getLine
  n <- fmap read getLine
  inp <- forM [1..n] $ \_ -> do
           [t, l, m, c] <- fmap words getLine
           return $ if l == "h" then (read t, home, 0, read m, head c)
                  else (read t, away, 1, read m, head c)
  solve (sort inp)

solve :: [(Int, String, Int, Int, Char)] -> IO ()
solve f = foldl g (return M.empty) f >> return ()
  where
    g :: IO (M.Map (Int, Int) Int) -> (Int, String, Int, Int, Char) -> IO (M.Map (Int, Int) Int)
    g m (t, tn, b, pn, cc) = m >>= \ma -> case M.lookup (b, pn) ma of
                                         Nothing -> if cc == 'r'
                                                    then putStrLn (tn ++ " " ++ show pn ++ " " ++ show t)
                                                         >> return (M.insert (b, pn) 2 ma)
                                                    else return (M.insert (b, pn) 1 ma)
                                         Just x -> if cc == 'r'
                                                   then if x == 1
                                                        then putStrLn (tn ++ " " ++ show pn ++ " " ++ show t)
                                                             >> return (M.insert (b, pn) 2 ma)
                                                        else return ma
                                                   else if x == 1
                                                        then putStrLn (tn ++ " " ++ show pn ++ " " ++ show t)
                                                             >> return (M.insert (b, pn) 2 ma)
                                                        else return ma

import qualified Data.Map as M
main = interact $ unlines . map unwords . go . lines
go (h:a:n:q) = M.elems . M.foldWithKey f M.empty . M.filter (\(c,t) -> c >= 2) $ calc (M.fromList $ l) (map words q)
   where cr s = map (\x -> ((s,x),(0,0))) [1..99]
         l = (cr "h") ++ (cr "a")
         f k@(tm,p) (_,t) = M.insert t [g tm,show p,show t]
         g s | s == "h" = h
             | True = a
calc m q = foldl upd m q
     where upd x [st,tm,sp,k] = M.adjust f (tm,p) x
               where f (c,t') | c < 2 = (c + ik,t)
                              | True = (c,t')
                     ik | k == "y" = 1
                        | True = 2
                     t = read st
                     p = read sp

import Data.List (foldl', sortBy)
import qualified Data.Map as M
import Data.Function (on)

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

solve :: [String] -> [String]
solve (home:away:_:xs) = map format $ sortBy (compare `on` snd) $ M.toList
                       $ M.filter ((=="r") . fst) $ foldl' go M.empty xs
  where go m x = M.insertWith' f (team, number) (card, read time :: Integer) m
          where [time, team, number, card] = words x
                f (_, t) ("y", _) = ("r", t)
                f n _ = n
        format ((team, number), (_, time)) = unwords [ if team == "h" then home else away, number, show time ]
solve _ = undefined

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, TupleSections, OverloadedStrings #-}
import Control.Applicative
import Control.Exception hiding (mask)
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST (runSTUArray, runSTArray)
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Function
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.IntMap as IM
import qualified Data.Set as S
import qualified Data.IntSet as IS
import Data.STRef
import GHC.Arr (Array, STArray, Ix(..))
import Debug.Trace

bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs=case B.readInt bs of{Just(n,_)->n;_->error$"readInt error : bs = "++show bs;}
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep n f=foldr((>>).f)(return())[0..n-1]
rev n f=foldr((>>).f.negate)(return())[1-n..0]
for :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
for a b f=foldr((>>).f)(return())[a..b]
{-# INLINE rep #-}
{-# INLINE rev #-}
{-# INLINE for #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
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
  hName <- getLine
  aName <- getLine
  _n <- getLine
  ttpcs <- parse.words <$> getContents
  case solve hName aName ttpcs of
    [] -> return ()
    res -> putStr $ unlines res

type Time = Int
data Team = H | A deriving (Eq,Ord)
type Player = Int
data Color = Y | R deriving (Eq,Ord)

parse :: [String] -> [(Time,Team,Player,Color)]
parse (time:t:p:c:rest) = (read time, bool H A (t=="h"),read p,bool Y R (c=="y")) : parse rest
parse _ = []

solve :: String -> String -> [(Time,Team,Player,Color)] -> [String]
solve hName aName ttpcs = go [] [] ttpcs
   where
     showTeam H = hName
     showTeam A = aName
     go hps aps ((time,team,player,color):rest)
       | color == R = res : go hps aps rest
       | team == H, elem player hps = res : go hps aps rest
       | team == H = go (player:hps) aps rest
       | team == A, elem player aps = res : go hps aps rest
       | team == A = go hps (player:aps) rest
       | otherwise = undefined
      where
        res = unwords[showTeam team, show player, show time]
     go _ _ _ = []

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, TupleSections, OverloadedStrings #-}
import Control.Applicative
import Control.Exception hiding (mask)
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST (runSTUArray, runSTArray)
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Function
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.IntMap as IM
import qualified Data.Set as S
import qualified Data.IntSet as IS
import Data.STRef
import GHC.Arr (Array, STArray, Ix(..))
import Debug.Trace

bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs=case B.readInt bs of{Just(n,_)->n;_->error$"readInt error : bs = "++show bs;}
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep n f=foldr((>>).f)(return())[0..n-1]
rev n f=foldr((>>).f.negate)(return())[1-n..0]
for :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
for a b f=foldr((>>).f)(return())[a..b]
{-# INLINE rep #-}
{-# INLINE rev #-}
{-# INLINE for #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
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
  hName <- getLine
  aName <- getLine
  _n <- getLine
  ttpcs <- sort.parse.words <$> getContents
  case solve hName aName ttpcs of
    [] -> return ()
    res -> putStr $ unlines res

type Time = Int
data Team = H | A deriving (Eq,Ord)
type Player = Int
data Color = Y | R deriving (Eq,Ord)

parse :: [String] -> [(Time,Team,Player,Color)]
parse (time:t:p:c:rest) = (read time, bool H A (t=="h"),read p,bool Y R (c=="y")) : parse rest
parse _ = []

solve :: String -> String -> [(Time,Team,Player,Color)] -> [String]
solve hName aName ttpcs = go [] [] ttpcs
   where
     showTeam H = hName
     showTeam A = aName
     f (_,_,p,_) = p
     go hps aps ((time,team,player,color):rest)
       | color == R = res : go hps aps (filter ((player/=).f)rest)
       | team == H, elem player hps = res : go hps aps (filter ((player/=).f)rest)
       | team == H = go (player:hps) aps rest
       | team == A, elem player aps = res : go hps aps (filter ((player/=).f)rest)
       | team == A = go hps (player:aps) rest
       | otherwise = undefined
      where
        res = unwords[showTeam team, show player, show time]
     go _ _ _ = []

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, TupleSections, OverloadedStrings #-}
import Control.Applicative
import Control.Exception hiding (mask)
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST (runSTUArray, runSTArray)
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Function
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.IntMap as IM
import qualified Data.Set as S
import qualified Data.IntSet as IS
import Data.STRef
import GHC.Arr (Array, STArray, Ix(..))
import Debug.Trace

bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs=case B.readInt bs of{Just(n,_)->n;_->error$"readInt error : bs = "++show bs;}
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep n f=foldr((>>).f)(return())[0..n-1]
rev n f=foldr((>>).f.negate)(return())[1-n..0]
for :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
for a b f=foldr((>>).f)(return())[a..b]
{-# INLINE rep #-}
{-# INLINE rev #-}
{-# INLINE for #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
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
  hName <- getLine
  aName <- getLine
  _n <- getLine
  getContents>>=putStr.init.unlines.solve hName aName.sort.parse.words

type Time = Int
data Team = H | A deriving (Eq,Ord)
type Player = Int
data Color = Y | R deriving (Eq,Ord)

parse :: [String] -> [(Time,Team,Player,Color)]
parse (time:t:p:c:rest) = (read time, bool H A (t=="h"),read p,bool Y R (c=="y")) : parse rest
parse _ = []

solve :: String -> String -> [(Time,Team,Player,Color)] -> [String]
solve hName aName ttpcs = go [] [] ttpcs
   where
     showTeam H = hName
     showTeam A = aName
     go hps aps ((time,team,player,color):rest)
       | color == R = res : go hps aps rest
       | team == H, elem player hps = res : go hps aps rest
       | team == H = go (player:hps) aps rest
       | team == A, elem player aps = res : go hps aps rest
       | team == A = go hps (player:aps) rest
       | otherwise = undefined
      where
        res = unwords[showTeam team, show player, show time]
     go _ _ _ = []

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, TupleSections, OverloadedStrings #-}
import Control.Applicative
import Control.Exception hiding (mask)
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST (runSTUArray, runSTArray)
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Function
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.IntMap as IM
import qualified Data.Set as S
import qualified Data.IntSet as IS
import Data.STRef
import GHC.Arr (Array, STArray, Ix(..))
import Debug.Trace

bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs=case B.readInt bs of{Just(n,_)->n;_->error$"readInt error : bs = "++show bs;}
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep n f=foldr((>>).f)(return())[0..n-1]
rev n f=foldr((>>).f.negate)(return())[1-n..0]
for :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
for a b f=foldr((>>).f)(return())[a..b]
{-# INLINE rep #-}
{-# INLINE rev #-}
{-# INLINE for #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
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
  hName <- getLine
  aName <- getLine
  _n <- getLine
  getContents>>=putStr.unlines.solve  hName aName.sort.parse.words

type Time = Int
data Team = H | A deriving (Eq,Ord)
type Player = Int
data Color = Y | R deriving (Eq,Ord)

parse :: [String] -> [(Time,Team,Player,Color)]
parse (time:t:p:c:rest) = (read time, bool H A (t=="h"),read p,bool Y R (c=="y")) : parse rest
parse _ = []

solve :: String -> String -> [(Time,Team,Player,Color)] -> [String]
solve hName aName ttpcs = go [] [] ttpcs
   where
     showTeam H = hName
     showTeam A = aName
     go hps aps ((time,team,player,color):rest)
       | color == R = res : go hps aps rest
       | team == H, elem player hps = res : go hps aps rest
       | team == H = go (player:hps) aps rest
       | team == A, elem player aps = res : go hps aps rest
       | team == A = go hps (player:aps) rest
       | otherwise = undefined
      where
        res = unwords[showTeam team, show player, show time]
     go _ _ _ = []

import Control.Monad
import qualified Data.Map as M
import Data.List (sort)

main :: IO ()
main = do
  home <- getLine
  away <- getLine
  n <- fmap read getLine
  inp <- forM [1..n] $ \_ -> do
           [t, l, m, c] <- fmap words getLine
           return $ if l == "h" then (read t, home, read m, head c)
                  else (read t, away, read m, head c)
  solve (sort inp)

solve :: [(Int, String, Int, Char)] -> IO ()
solve f = foldl g (return M.empty) f >> return ()
  where
    g :: IO (M.Map Int Int) -> (Int, String, Int, Char) -> IO (M.Map Int Int)
    g m (t, tn, pn, cc) = m >>= \ma -> case M.lookup pn ma of
                                         Nothing -> if cc == 'r'
                                                    then putStrLn (tn ++ " " ++ show pn ++ " " ++ show t)
                                                         >> return (M.insert pn 2 ma)
                                                    else return (M.insert pn 1 ma)
                                         Just x -> if cc == 'r'
                                                   then if x == 1
                                                        then putStrLn (tn ++ " " ++ show pn ++ " " ++ show t)
                                                             >> return (M.insert pn 2 ma)
                                                        else return ma
                                                   else if x == 1
                                                        then putStrLn (tn ++ " " ++ show pn ++ " " ++ show t)
                                                             >> return (M.insert pn 2 ma)
                                                        else return ma


This is the hard version of the problem. The only difference is the constraints on $$$n$$$ and $$$k$$$. You can make hacks only if all versions of the problem are solved.You have a string $$$s$$$, and you can do two types of operations on it:   Delete the last character of the string.  Duplicate the string: $$$s:=s+s$$$, where $$$+$$$ denotes concatenation. You can use each operation any number of times (possibly none).Your task is to find the lexicographically smallest string of length exactly $$$k$$$ that can be obtained by doing these operations on string $$$s$$$.A string $$$a$$$ is lexicographically smaller than a string $$$b$$$ if and only if one of the following holds:  $$$a$$$ is a prefix of $$$b$$$, but $$$a\ne b$$$;  In the first position where $$$a$$$ and $$$b$$$ differ, the string $$$a$$$ has a letter that appears earlier in the alphabet than the corresponding letter in $$$b$$$.

The first line contains two integers $$$n$$$, $$$k$$$ ($$$1 \leq n, k \leq 5\cdot 10^5$$$) — the length of the original string $$$s$$$ and the length of the desired string. The second line contains the string $$$s$$$, consisting of $$$n$$$ lowercase English letters.

Print the lexicographically smallest string of length $$$k$$$ that can be obtained by doing the operations on string $$$s$$$.

NoteIn the first test, it is optimal to make one duplication: "dbcadabc" $$$\to$$$ "dbcadabcdbcadabc".In the second test it is optimal to delete the last $$$3$$$ characters, then duplicate the string $$$3$$$ times, then delete the last $$$3$$$ characters to make the string have length $$$k$$$."abcd" $$$\to$$$ "abc" $$$\to$$$ "ab" $$$\to$$$ "a" $$$\to$$$ "aa" $$$\to$$$ "aaaa" $$$\to$$$ "aaaaaaaa" $$$\to$$$ "aaaaaaa" $$$\to$$$ "aaaaaa" $$$\to$$$ "aaaaa".

{-# LANGUAGE FlexibleContexts #-}
import qualified Data.ByteString.Char8 as BS
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST
import Data.Array.Unboxed
import Data.Bits
import Data.Bool
import Data.Char
import Data.Int
import Data.List
import Data.Maybe
import Data.Ord
import Data.Ratio
import Data.Tuple
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import System.IO
import System.IO.Unsafe

(><) a b = a Seq.>< b

deb name s e = seq s unsafePerformIO $! do
    hPutStrLn stderr $ " " ++ name ++ " = " ++ show s
    return e

parseInt = fst . fromJust . BS.readInt
parseInteger = fst . fromJust . BS.readInteger

modifyArray f a i = readArray a i >>= \v -> writeArray a i (f v)

forFoldM_ v s f = foldM_ f v s

suffixArray :: String -> UArray Int Int
suffixArray s = goSa 1 saInit rInit
    where
        n = length s
        saInit = listArray (0,n-1) [0..]
        rInit = listArray (0,n-1) (map ord s)

        goSa k sa r
            | k >= n = sa
            | otherwise =
                let
                    sa0 = csort k sa r
                    sa1 = csort 0 sa0 r
                    vs = [(r ! (sa1 ! i), getR ((sa1 ! i) + k)) | i <- [0..n-1]]
                    newR = zip (elems sa1) $ scanl (\s (a,b) -> if a == b then s else s + 1) 0 $ zip vs (tail vs)
                in
                    goSa (2*k) sa1 (array (0,n-1) newR)

         where
            getR t = if t < n then r ! t else 0

            csort :: Int -> UArray Int Int -> UArray Int Int -> UArray Int Int
            csort k sa r = runST $ do
                let cl = max 255 n
                c <- newArray (0, cl-1) 0 :: ST s (STUArray s Int Int)
                forM_ [0..n-1] $ \i -> do
                    modifyArray (+1) c (getR (i + k))
                forFoldM_ 0 [0..cl-1] $ \s i -> do
                    t <- readArray c i
                    writeArray c i s
                    return $ s + t

                rr <- forM [0..n-1] $ \i -> do
                    let sai = sa ! i
                        j = getR $ sai + k
                    t <- readArray c j
                    writeArray c j $ t + 1
                    return (t, sai)
                return $ array (0,n-1) rr

zFunction :: String -> UArray Int Int
zFunction s0 = runSTUArray $ do
    let n = length s0
        s = listArray (0,n-1) s0 :: UArray Int Char
    z <- newArray (0,n-1) 0 :: ST s (STUArray s Int Int)
    forFoldM_ (0,0) [1..n-1] $ \(l,r) i -> do
        when (i <= r) $ readArray z (i-l) >>= \v -> writeArray z i $ min (r-i+1) v
        let loop = do
            zi <- readArray z i
            when (i + zi < n && (s ! zi) == (s ! (i + zi))) $ do
                writeArray z i (zi+1)
                loop
        loop
        zi <- readArray z i
        return $ if i + zi - 1 > r then (i,i+zi-1) else (l,r)
    return z

solve :: String -> Int -> String
solve s0 k =
    let
        s = s0 ++ "~"
        n = length s
        z = zFunction s
        a = listArray (0,n-1) s :: UArray Int Char
        l = foldr1 op [1..]
        op i j = if (a ! (i + (z ! i))) > (a ! (z ! i)) then i else j
    in
        take k $ cycle (take l s0)

main = do
    [n,k] <- map parseInt . BS.words <$> BS.getLine
    s <- dropWhileEnd isSpace . BS.unpack <$> BS.getLine
    putStrLn $ solve s k

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

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

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

data State a = Node (Maybe (Int, State a)) [a] (State a)

main :: IO ()
main = do
  [_, k] <- getInts
  str@(_ : str') <- filter (not . isSpace) . C.unpack <$> C.getLine
  let initial = Node Nothing str first
      first = Node (Just (1, initial)) str' (extend 2 initial str')
      findNext char node@(Node p s n)
        | char == head s = n
        | isJust p = findNext char (snd $ fromJust p)
        | otherwise = node
      extend _ _ [] = Node Nothing [] undefined
      extend idx prev (char : chars') = node'
        where node' = Node (Just (idx, prev')) chars' (extend (idx + 1) prev' chars')
              prev' = findNext char prev
      getIndex (Node Nothing _ _) = 0
      getIndex (Node (Just (i, _)) _ _) = i
      step node@(Node (Just (idx, prev)) [] _) _ = Left (idx - getIndex prev)
      step node@(Node (Just (idx, prev)) (char : _) next) _
        | getNextChar prev < char = Left (idx - getIndex prev)
        | otherwise = Right next
        where getNextChar (Node _ (c : _) _) = c
              getNextChar _ = error ""
      Left num = foldM step first $ repeat ()
      result = take k $ cycle $ take num str
  hPutBuilder stdout $ string7 result <> charUtf8 '\n'

{-# LANGUAGE FlexibleContexts #-}
import qualified Data.ByteString.Char8 as BS
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST
import Data.Array.Unboxed
import Data.Bits
import Data.Bool
import Data.Char
import Data.Int
import Data.List
import Data.Maybe
import Data.Ord
import Data.Ratio
import Data.Tuple
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import System.IO
import System.IO.Unsafe

(><) a b = a Seq.>< b

deb name s e = seq s unsafePerformIO $! do
    hPutStrLn stderr $ " " ++ name ++ " = " ++ show s
    return e

parseInt = fst . fromJust . BS.readInt
parseInteger = fst . fromJust . BS.readInteger

modifyArray f a i = readArray a i >>= \v -> writeArray a i (f v)

forFoldM_ v s f = foldM_ f v s

suffixArray :: String -> UArray Int Int
suffixArray s = goSa 1 saInit rInit
    where
        n = length s
        saInit = listArray (0,n-1) [0..]
        rInit = listArray (0,n-1) (map ord s)

        goSa k sa r
            | k >= n = sa
            | otherwise =
                let
                    sa0 = csort k sa r
                    sa1 = csort 0 sa0 r
                    vs = [(r ! (sa1 ! i), getR ((sa1 ! i) + k)) | i <- [0..n-1]]
                    newR = zip (elems sa1) $ scanl (\s (a,b) -> if a == b then s else s + 1) 0 $ zip vs (tail vs)
                in
                    goSa (2*k) sa1 (array (0,n-1) newR)

         where
            getR t = if t < n then r ! t else 0

            csort :: Int -> UArray Int Int -> UArray Int Int -> UArray Int Int
            csort k sa r = runST $ do
                let cl = max 255 n
                c <- newArray (0, cl-1) 0 :: ST s (STUArray s Int Int)
                forM_ [0..n-1] $ \i -> do
                    modifyArray (+1) c (getR (i + k))
                forFoldM_ 0 [0..cl-1] $ \s i -> do
                    t <- readArray c i
                    writeArray c i s
                    return $ s + t

                rr <- forM [0..n-1] $ \i -> do
                    let sai = sa ! i
                        j = getR $ sai + k
                    t <- readArray c j
                    writeArray c j $ t + 1
                    return (t, sai)
                return $ array (0,n-1) rr

zFunction :: String -> UArray Int Int
zFunction s0 = runSTUArray $ do
    let n = length s0
        s = listArray (0,n-1) s0 :: UArray Int Char
    z <- newArray (0,n-1) 0 :: ST s (STUArray s Int Int)
    forFoldM_ (0,0) [1..n-1] $ \(l,r) i -> do
        when (i <= r) $ readArray z (i-1) >>= \v -> writeArray z i $ min (r-i+1) v
        let loop = do
            zi <- readArray z i
            when (i + zi < n && (s ! zi) == (s ! (i + zi))) $ do
                writeArray z i (zi+1)
                loop
        loop
        zi <- readArray z i
        return $ if i + zi - 1 > r then (i,i+zi-1) else (l,r)
    return z

solve :: String -> Int -> String
solve s0 k =
    let
        s = s0 ++ "~"
        n = length s
        z = zFunction s
        a = listArray (0,n-1) s :: UArray Int Char
        l = foldr1 op [1..]
        op i j = if (a ! (i + (z ! i))) > (a ! (z ! i)) then i else j
    in
        take k $ cycle (take l s0)

main = do
    [n,k] <- map parseInt . BS.words <$> BS.getLine
    s <- dropWhileEnd isSpace . BS.unpack <$> BS.getLine
    putStrLn $ solve s k


'Jeopardy!' is an intellectual game where players answer questions and earn points. Company Q conducts a simplified 'Jeopardy!' tournament among the best IT companies. By a lucky coincidence, the old rivals made it to the finals: company R1 and company R2. The finals will have n questions, m of them are auction questions and n - m of them are regular questions. Each question has a price. The price of the i-th question is ai points. During the game the players chose the questions. At that, if the question is an auction, then the player who chose it can change the price if the number of his current points is strictly larger than the price of the question. The new price of the question cannot be less than the original price and cannot be greater than the current number of points of the player who chose the question. The correct answer brings the player the points equal to the price of the question. The wrong answer to the question reduces the number of the player's points by the value of the question price.The game will go as follows. First, the R2 company selects a question, then the questions are chosen by the one who answered the previous question correctly. If no one answered the question, then the person who chose last chooses again.All R2 employees support their team. They want to calculate what maximum possible number of points the R2 team can get if luck is on their side during the whole game (they will always be the first to correctly answer questions). Perhaps you are not going to be surprised, but this problem was again entrusted for you to solve.

The first line contains two space-separated integers n and m (1 ≤ n, m ≤ 100; m ≤ min(n, 30)) — the total number of questions and the number of auction questions, correspondingly. The second line contains n space-separated integers a1, a2, ..., an (1 ≤ ai ≤ 107) — the prices of the questions. The third line contains m distinct integers bi (1 ≤ bi ≤ n) — the numbers of auction questions. Assume that the questions are numbered from 1 to n.

In the single line, print the answer to the problem — the maximum points the R2 company can get if it plays optimally well. It is guaranteed that the answer fits into the integer 64-bit signed type.

import Data.List
import Data.Array.Unboxed
import qualified Data.IntSet as S

data Question = DailyDouble Int | Normal Int
  deriving (Show,Eq,Ord)

rsort = sortBy (flip compare)

solve :: [Question] -> Integer
solve pairs = foldl' go 0 pairs
  where go t (Normal s) = t+(fromIntegral s)
        go t (DailyDouble s) = t + max t (fromIntegral s)

main = do
  (n:m:_) <- fmap (map read . words) getLine
  scores <- fmap (map read . words) getLine
  dset <- fmap (S.fromList . map read . words) getLine
  let arr = listArray (1,n) scores :: UArray Int Int
      best = solve $ rsort [ q | i <- [1..n], let q = if S.member i dset then DailyDouble (arr!i) else Normal (arr!i) ]
  print best

import Data.List
import Data.Array.Unboxed
import qualified Data.IntSet as S

data Question = DailyDouble Int | Normal Int
  deriving (Show,Eq,Ord)

rsort = sortBy (flip compare)

solve :: [Question] -> Int
solve pairs = foldl' go 0 pairs
  where go t (Normal s) = t+s
        go t (DailyDouble s) = t + max t s

main = do
  (n:m:_) <- fmap (map read . words) getLine
  scores <- fmap (map read . words) getLine
  dset <- fmap (S.fromList . map read . words) getLine
  let arr = listArray (1,n) scores :: UArray Int Int
      best = solve $ rsort [ q | i <- [1..n], let q = if S.member i dset then DailyDouble (arr!i) else Normal (arr!i) ]
  print best


The black king is standing on a chess field consisting of 109 rows and 109 columns. We will consider the rows of the field numbered with integers from 1 to 109 from top to bottom. The columns are similarly numbered with integers from 1 to 109 from left to right. We will denote a cell of the field that is located in the i-th row and j-th column as (i, j).You know that some squares of the given chess field are allowed. All allowed cells of the chess field are given as n segments. Each segment is described by three integers ri, ai, bi (ai ≤ bi), denoting that cells in columns from number ai to number bi inclusive in the ri-th row are allowed.Your task is to find the minimum number of moves the king needs to get from square (x0, y0) to square (x1, y1), provided that he only moves along the allowed cells. In other words, the king can be located only on allowed cells on his way.Let us remind you that a chess king can move to any of the neighboring cells in one move. Two cells of a chess field are considered neighboring if they share at least one point.

The first line contains four space-separated integers x0, y0, x1, y1 (1 ≤ x0, y0, x1, y1 ≤ 109), denoting the initial and the final positions of the king. The second line contains a single integer n (1 ≤ n ≤ 105), denoting the number of segments of allowed cells. Next n lines contain the descriptions of these segments. The i-th line contains three space-separated integers ri, ai, bi (1 ≤ ri, ai, bi ≤ 109, ai ≤ bi), denoting that cells in columns from number ai to number bi inclusive in the ri-th row are allowed. Note that the segments of the allowed cells can intersect and embed arbitrarily. It is guaranteed that the king's initial and final position are allowed cells. It is guaranteed that the king's initial and the final positions do not coincide. It is guaranteed that the total length of all given segments doesn't exceed 105.

If there is no path between the initial and final position along allowed cells, print -1. Otherwise print a single integer — the minimum number of moves the king needs to get from the initial position to the final one.

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

gao s@(sx,sy) t@(tx,ty) e =
  if M.member s d && M.member t d
    then fromJust $ M.lookup t $ bfs [s] (M.insert s 0 d)
    else -1
  where
    d = M.fromList [((i, j), -1) | [i, l, r] <- e, j <- [l .. r]]
    bfs [] d = d
    bfs (v@(x,y):vs) d = bfs (vs ++ w) $ foldl (\i k -> M.insert k t i) d w
      where
        w = [(i, j) |
            i <- [x - 1 .. x + 1],
            j <- [y - 1 .. y + 1],
            M.lookup (i, j) d == Just (-1)]
        t = succ $ fromJust $ M.lookup v d

main = do
  [x0, y0, x1, y1] <- getArray
  [n] <- getArray
  e <- replicateM n getArray
  print $ gao (x0, y0) (x1, y1) e
  where
    getArray = fmap (map (fst . fromJust . C.readInt) . C.words) C.getLine

{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import qualified Data.ByteString.Char8 as B
import Data.List
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Set as S

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

parse (r:a:b:rabs) = [(r,c)|c<-[a..b]] ++ parse rabs
parse _ = []

main = do
  [x0,y0,x1,y1] <- map read.words <$> getLine ::IO [Int]
  _ <- getLine
  gr <- parse.map readInt.B.words <$> B.getContents :: IO [(Int,Int)]
  print $ bfs (S.fromList $ (x1,y1):gr) (x0,y0) (x1,y1)

type Vertex = (Int,Int)
type Cost = Int

bfs :: S.Set Vertex -> Vertex -> Vertex -> Cost
bfs gr start goal = go (Q [start] []) $ M.singleton start 0
   where
     neighbors (x,y) = filter (`S.member`gr) [(x+1,y),(x+1,y+1),(x,y+1),(x-1,y+1),(x-1,y),(x-1,y-1),(x,y-1),(x+1,y-1)]
     go queue dist
       | isEmpty queue = -1
       | q == goal = fromJust $ M.lookup goal dist
       | otherwise = go (foldr enq rest nexts) $! foldl' (\m k->M.insert k (dq+1) m) dist nexts
      where
        (q,rest) = deq queue
        dq = fromJust $ M.lookup q dist
        nexts = filter (isNothing.(`M.lookup`dist)) $ neighbors q

data Queue = Q [Vertex] [Vertex]

isEmpty (Q [] []) = True
isEmpty _ = False

enq x (Q f r) = Q f (x:r)

deq (Q (f:fs) rs) = (f,Q fs rs)
deq (Q _ rs) = deq (Q (reverse rs) [])

{-# OPTIONS_GHC -O2  -funbox-strict-fields #-}

import Control.Applicative
import Control.Monad
import Control.Monad.ST
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Set as S
import Data.STRef

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

parse (r:a:b:rabs) = [(r,c)|c<-[a..b]] ++ parse rabs
parse _ = []

main = do
  [x0,y0,x1,y1] <- map read.words <$> getLine ::IO [Int]
  _ <- getLine
  gr <- parse.map readInt.B.words <$> B.getContents :: IO [(Int,Int)]
  print $ dijkstra ((x0,y0):(x1,y1):gr) (x0,y0) (x1,y1)

type Vertex = (Int,Int)
type Cost = Int
type Graph = S.Set (Int,Int)

inf :: Cost
inf = 1000000000

neighbors (x,y) = [(x+1,y),(x+1,y+1),(x,y+1),(x-1,y+1),(x-1,y),(x-1,y-1),(x,y-1),(x+1,y-1)]

dijkstra gr start goal = runST $ do
  dist <- newSTRef M.empty :: ST s (STRef  s (M.Map Vertex Cost))
  unvisited <-  newSTRef (S.fromList gr) :: ST s (STRef s (S.Set Vertex))
  let get v = do
         m <- readSTRef dist
         return $! maybe inf id $! M.lookup v m
      put v d = do
         m <- readSTRef dist
         writeSTRef dist $! M.insertWith min v d m
      isUnvisited v = do
         s <- readSTRef unvisited
         return $! S.member v s
      visit v =  do
         s <- readSTRef unvisited
         writeSTRef unvisited $! S.delete v s

  let go heap
        | isEmpty heap = do ans <- get goal; if ans==inf then return $ -1 else return ans
        | otherwise = do
            let (v,vcost,rest) = deleteFindMin heap
            dv <- get v
            visit v
            if vcost > dv
               then go rest
               else do
                 nextheap <- fmap(foldr ins rest.catMaybes).forM (neighbors v) $ \nv -> do
                   unvisited <- isUnvisited nv
                   if unvisited
                      then do
                        let newdnv = vcost + 1
                        olddnv <- get nv
                        if newdnv < olddnv
                         then do
                           put nv newdnv
                           return $ Just (nv,newdnv)
                         else return Nothing
                      else return Nothing
                 visit v
                 go nextheap
  put start 0
  visit start
  go $ ins (start,0) Empty

-- Pairing heap for Dijkstra
data Heap  = Empty | Fork !Vertex !Cost [Heap]

isEmpty :: Heap -> Bool
isEmpty Empty = True
isEmpty _ = False

ins :: (Vertex, Cost) -> Heap -> Heap
ins (v,cost) h = merge (Fork v cost []) h

deleteFindMin :: Heap -> (Vertex, Cost, Heap)
deleteFindMin (Fork v cost hs) = (v, cost, mergePairs hs)

merge :: Heap -> Heap -> Heap
merge Empty hy = hy
merge hx Empty = hx
merge hx@(Fork _ x _) hy@(Fork _ y _)
  | x <= y    = join hx hy
  | otherwise = join hy hx
 where
   join (Fork v cost hs) h = Fork v cost (h:hs)

mergePairs :: [Heap] -> Heap
mergePairs []       = Empty
mergePairs [x]      = x
mergePairs (x:y:hs) = merge (merge x y) (mergePairs hs)


You are given $$$n$$$ of integers $$$a_1, a_2, \ldots, a_n$$$. Process $$$q$$$ queries of two types: query of the form "0 $$$x_j$$$": add the value $$$x_j$$$ to all even elements of the array $$$a$$$, query of the form "1 $$$x_j$$$": add the value $$$x_j$$$ to all odd elements of the array $$$a$$$.Note that when processing the query, we look specifically at the odd/even value of $$$a_i$$$, not its index.After processing each query, print the sum of the elements of the array $$$a$$$.Please note that the answer for some test cases won't fit into 32-bit integer type, so you should use at least 64-bit integer type in your programming language (like long long for C++).

The first line of the input contains an integer $$$t$$$ $$$(1 \leq t \leq 10^4$$$) — the number of test cases. The descriptions of the test cases follow. The first line of each test case contains two integers $$$n$$$ and $$$q$$$ ($$$1 \leq n$$$, $$$q \leq 10^5$$$) — the length of array $$$a$$$ and the number of queries. The second line of each test case contains exactly $$$n$$$ integers: $$$a_1, a_2, \ldots, a_n$$$ ($$$1 \leq a_i \leq 10^9$$$) — elements of the array $$$a$$$. The following $$$q$$$ lines contain queries as two integers $$$type_j$$$ and $$$x_j$$$ $$$(0 \leq type_j \leq 1$$$, $$$1 \leq x_j \leq 10^4$$$). It is guaranteed that the sum of values $$$n$$$ over all test cases in a test does not exceed $$$10^5$$$. Similarly, the sum of values $$$q$$$ over all test cases does not exceed $$$10^5$$$.

For each test case, print $$$q$$$ numbers: the sum of the elements of the array $$$a$$$ after processing a query.

{-# LANGUAGE RecordWildCards #-}
module Main where

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

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

data Values = Values
  { valuesSum :: Int
  , numberEven :: Int
  , numberOdd :: Int
  }

data Query = Query
  { onEven :: Bool
  , summand :: Int
  }

toValues vs = Values
  { valuesSum = sum vs
  , numberEven = length $ filter even vs
  , numberOdd = length $ filter odd vs
  }

processQuery :: Values -> Query -> Values
processQuery Values{..} Query{..}
  | onEven      = Values{ valuesSum = valuesSum + summand * numberEven
                        , numberEven = if even summand then numberEven else 0
                        , numberOdd = if even summand then numberOdd else numberEven + numberOdd
                        }
  | otherwise   = Values{ valuesSum = valuesSum + summand * numberOdd
                        , numberEven = if even summand then numberEven else numberEven + numberOdd
                        , numberOdd = if even summand then numberOdd else 0
                        }

processQueries :: Values -> [Query] -> [Values]
processQueries vs qs = drop 1 $ scanl processQuery vs qs

parseQuery :: IO Query
parseQuery = do
  [e, s] <- map parseInt . B.words <$> B.getLine
  pure $ Query (e == 0) s

handleProblem :: IO ()
handleProblem = do
  [n, q] <- map parseInt . B.words <$> B.getLine
  vs <- toValues . map parseInt . B.words <$> B.getLine
  qs <- replicateM q parseQuery
  putStrLn $ intercalate "\n" $ map (show . valuesSum) $ processQueries vs qs

main :: IO ()
main = do
  numberProblems <- read <$> getLine
  replicateM_ numberProblems handleProblem

parseInt :: B.ByteString -> Int
parseInt = maybe 0 fst . B.readInt

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

import qualified Data.ByteString.Char8 as B8
import qualified Data.String as S

import Control.Arrow ((>>>))
import Data.Functor ((<&>))
import Data.Maybe
import qualified Data.Traversable as T

import qualified Control.Applicative as A
import qualified Control.Monad as M
import qualified Control.Monad.State as MS
import qualified Control.Monad.Trans as MT
import qualified Control.Monad.Trans.Maybe as M

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

import qualified Data.IntSet as IS
import qualified Data.IntMap as IM
import qualified Data.Set as S
import Data.List (sortBy, sortOn)

import Data.Char
import Data.Int

import System.IO (stdin, stdout, hFlush)
import Text.Printf

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

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

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

#else

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

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

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

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

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

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

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

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

{- solution -}

type SolutionState = (IM.IntMap (Int, Int64))

mergeX :: (Int, Int64) -> (Int, Int64) -> (Int, Int64)
mergeX (cnt1, s1) (cnt2, s2) = (cnt1 + cnt2, s1 + s2)

preSolve :: Int -> [Int] -> SolutionState
preSolve n as = L.foldr (\x mp -> IM.insertWith mergeX (x `mod` 2) (1, fromIntegral x) mp) emptyState as
    where
        emptyState :: SolutionState
        emptyState = IM.fromList [(0, (0, 0)), (1, (0, 0))]

query :: (Monad m) => Int -> Int -> MS.StateT SolutionState m Int64
query mod2 x = do
    (cnt, s) <- MS.gets (IM.! mod2)

    let newMod2 = (mod2 + x) `mod` 2
    MS.modify (IM.insertWith mergeX mod2 (-cnt, -s))
    MS.modify (IM.insertWith mergeX newMod2 (cnt, s))
    MS.modify (IM.insertWith mergeX newMod2 (0, fromIntegral $ x * cnt))

    tracingM "mod2" mod2
    tracingM "x" x

    (_, s0) <- MS.gets (IM.! 0)
    (_, s1) <- MS.gets (IM.! 1)
    return $ s0 + s1

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    M.replicateM_ t $ do
        [n, q] <- B8.getLine <&> readIntB8s
        as <- B8.getLine <&> readIntB8s
        let state = preSolve n as
        flip MS.evalStateT state . M.replicateM_ q $ do
            [mod2, x] <- MT.lift $ B8.getLine <&> readIntB8s
            tracingM "mod2" mod2
            tracingM "x" x
            answer <- query mod2 x
            MT.lift $ printf "%lld\n" answer


Vus the Cossack has two binary strings, that is, strings that consist only of "0" and "1". We call these strings $$$a$$$ and $$$b$$$. It is known that $$$|b| \leq |a|$$$, that is, the length of $$$b$$$ is at most the length of $$$a$$$.The Cossack considers every substring of length $$$|b|$$$ in string $$$a$$$. Let's call this substring $$$c$$$. He matches the corresponding characters in $$$b$$$ and $$$c$$$, after which he counts the number of positions where the two strings are different. We call this function $$$f(b, c)$$$.For example, let $$$b = 00110$$$, and $$$c = 11000$$$. In these strings, the first, second, third and fourth positions are different.Vus the Cossack counts the number of such substrings $$$c$$$ such that $$$f(b, c)$$$ is even.For example, let $$$a = 01100010$$$ and $$$b = 00110$$$. $$$a$$$ has four substrings of the length $$$|b|$$$: $$$01100$$$, $$$11000$$$, $$$10001$$$, $$$00010$$$.  $$$f(00110, 01100) = 2$$$; $$$f(00110, 11000) = 4$$$; $$$f(00110, 10001) = 4$$$; $$$f(00110, 00010) = 1$$$. Since in three substrings, $$$f(b, c)$$$ is even, the answer is $$$3$$$.Vus can not find the answer for big strings. That is why he is asking you to help him.

The first line contains a binary string $$$a$$$ ($$$1 \leq |a| \leq 10^6$$$) — the first string. The second line contains a binary string $$$b$$$ ($$$1 \leq |b| \leq |a|$$$) — the second string.

NoteThe first example is explained in the legend.In the second example, there are five substrings that satisfy us: $$$1010$$$, $$$0101$$$, $$$1111$$$, $$$1111$$$.

import Data.Char

countElem :: Eq a => a -> [a] -> Int
countElem x l = sum . map (\x -> if x then 1 else 0) . map (== x) $ l

main = do
	a <- fmap (scanl (+) 0 . map digitToInt) getLine
	b <- getLine
	let k = length b
	let cnt = countElem 0 . map (`mod` 2) . zipWith (-) (drop k a) $ a
	print $ if (countElem '1' b `mod` 2 == 0) then cnt else (length a - k - cnt)

import Data.Char

countElem :: Eq a => a -> [a] -> Int
countElem x l = sum . map (\x -> if x then 1 else 0) . map (== x) $ l

main = do
	a <- fmap (scanl (+) 0 . map digitToInt) getLine
	b <- getLine
	let k = length b
	let cnt = countElem 0 . map (`mod` 2) . zipWith (-) (drop k a) $ a
	print $ if (countElem '1' b `mod` 2 == 0) then cnt else (length a - length b - cnt + 1)


Uh oh! Ray lost his array yet again! However, Omkar might be able to help because he thinks he has found the OmkArray of Ray's array. The OmkArray of an array $$$a$$$ with elements $$$a_1, a_2, \ldots, a_{2k-1}$$$, is the array $$$b$$$ with elements $$$b_1, b_2, \ldots, b_{k}$$$ such that $$$b_i$$$ is equal to the median of $$$a_1, a_2, \ldots, a_{2i-1}$$$ for all $$$i$$$. Omkar has found an array $$$b$$$ of size $$$n$$$ ($$$1 \leq n \leq 2 \cdot 10^5$$$, $$$-10^9 \leq b_i \leq 10^9$$$). Given this array $$$b$$$, Ray wants to test Omkar's claim and see if $$$b$$$ actually is an OmkArray of some array $$$a$$$. Can you help Ray?The median of a set of numbers $$$a_1, a_2, \ldots, a_{2i-1}$$$ is the number $$$c_{i}$$$ where $$$c_{1}, c_{2}, \ldots, c_{2i-1}$$$ represents $$$a_1, a_2, \ldots, a_{2i-1}$$$ sorted in nondecreasing order.

Each test contains multiple test cases. The first line contains a single integer $$$t$$$ ($$$1 \leq t \leq 10^4$$$) — the number of test cases. Description of the test cases follows. The first line of each test case contains an integer $$$n$$$ ($$$1 \leq n \leq 2 \cdot 10^5$$$) — the length of the array $$$b$$$. The second line contains $$$n$$$ integers $$$b_1, b_2, \ldots, b_n$$$ ($$$-10^9 \leq b_i \leq 10^9$$$) — the elements of $$$b$$$. It is guaranteed the sum of $$$n$$$ across all test cases does not exceed $$$2 \cdot 10^5$$$.

For each test case, output one line containing YES if there exists an array $$$a$$$ such that $$$b_i$$$ is the median of $$$a_1, a_2, \dots, a_{2i-1}$$$ for all $$$i$$$, and NO otherwise. The case of letters in YES and NO do not matter (so yEs and No will also be accepted).

NoteIn the second case of the first sample, the array $$$[4]$$$ will generate an OmkArray of $$$[4]$$$, as the median of the first element is $$$4$$$.In the fourth case of the first sample, the array $$$[3, 2, 5]$$$ will generate an OmkArray of $$$[3, 3]$$$, as the median of $$$3$$$ is $$$3$$$ and the median of $$$2, 3, 5$$$ is $$$3$$$.In the fifth case of the first sample, the array $$$[2, 1, 0, 3, 4, 4, 3]$$$ will generate an OmkArray of $$$[2, 1, 2, 3]$$$ as   the median of $$$2$$$ is $$$2$$$  the median of $$$0, 1, 2$$$ is $$$1$$$  the median of $$$0, 1, 2, 3, 4$$$ is $$$2$$$  and the median of $$$0, 1, 2, 3, 3, 4, 4$$$ is $$$3$$$. In the second case of the second sample, the array $$$[1, 0, 4, 3, 5, -2, -2, -2, -4, -3, -4, -1, 5]$$$ will generate an OmkArray of $$$[1, 1, 3, 1, 0, -2, -1]$$$, as   the median of $$$1$$$ is $$$1$$$  the median of $$$0, 1, 4$$$ is $$$1$$$  the median of $$$0, 1, 3, 4, 5$$$ is $$$3$$$  the median of $$$-2, -2, 0, 1, 3, 4, 5$$$ is $$$1$$$  the median of $$$-4, -2, -2, -2, 0, 1, 3, 4, 5$$$ is $$$0$$$  the median of $$$-4, -4, -3, -2, -2, -2, 0, 1, 3, 4, 5$$$ is $$$-2$$$  and the median of $$$-4, -4, -3, -2, -2, -2, -1, 0, 1, 3, 4, 5, 5$$$ is $$$-1$$$ For all cases where the answer is NO, it can be proven that it is impossible to find an array $$$a$$$ such that $$$b$$$ is the OmkArray of $$$a$$$.

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

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

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

main :: IO ()
main = do
  [t] <- getInts
  output <- fmap mconcat $ replicateM t $ do
    [n] <- getInts
    (a : as) <- getInts
    let result = isJust $ foldM acc ([], a, []) as
        notNull = not . null
        prepend x [] = [x]
        prepend x (y : ys)
          | x == y = y : ys
          | otherwise = x : y : ys
        acc (ls, x, rs) y
          | y < x = if notNull ls && y < head ls then Nothing else if notNull ls && y == head ls then Just (tail ls, y, prepend x rs) else Just (ls, y, prepend x rs)
          | x < y = if notNull rs && y > head rs then Nothing else if notNull rs && y == head rs then Just (prepend x ls, y, tail rs) else Just (prepend x ls, y, rs)
          | otherwise = Just (ls, x, rs)
    return $ string7 (if result then "YES" else "NO") `mappend` charUtf8 '\n'
  hPutBuilder stdout output

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

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

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

main :: IO ()
main = do
  [t] <- getInts
  output <- fmap mconcat $ replicateM t $ do
    [n] <- getInts
    (a : as) <- getInts
    let result = isJust $ foldM acc ([], a, []) as
        notNull = not . null
        prepend x [] = [x]
        prepend x (y : ys)
          | x == y = y : ys
          | otherwise = x : y : ys
        acc (ls, x, rs) y
          | y < x = if notNull ls && y < head ls then Nothing else if notNull ls && y == head ls then Just (tail ls, y, rs) else Just (ls, y, prepend x rs)
          | x < y = if notNull rs && y > head rs then Nothing else if notNull rs && y == head rs then Just (ls, y, tail rs) else Just (prepend x ls, y, rs)
          | otherwise = Just (ls, x, rs)
    return $ string7 (if result then "YES" else "NO") `mappend` charUtf8 '\n'
  hPutBuilder stdout output


Ayrat has number n, represented as it's prime factorization pi of size m, i.e. n = p1·p2·...·pm. Ayrat got secret information that that the product of all divisors of n taken modulo 109 + 7 is the password to the secret data base. Now he wants to calculate this value.

The first line of the input contains a single integer m (1 ≤ m ≤ 200 000) — the number of primes in factorization of n.  The second line contains m primes numbers pi (2 ≤ pi ≤ 200 000).

Print one integer — the product of all divisors of n modulo 109 + 7.

NoteIn the first sample n = 2·3 = 6. The divisors of 6 are 1, 2, 3 and 6, their product is equal to 1·2·3·6 = 36.In the second sample 2·3·2 = 12. The divisors of 12 are 1, 2, 3, 4, 6 and 12. 1·2·3·4·6·12 = 1728.

module Main where

import Control.Monad
import Control.Monad.State
import Data.List (group, sort)
import Data.Maybe (fromJust)
import Debug.Trace (trace)
import Text.Printf (printf)
import qualified Data.ByteString.Lazy.Char8 as L

modulo, moduloM1 :: Integer
modulo = 1000000000 + 7
moduloM1 = modulo - 1

getLambda :: [Integer] -> [(Int, Integer)]
getLambda = map toPair . group . sort
    where toPair ps = (length ps, head ps)

prefixModulo, suffixModulo :: [(Int, Integer)] -> [Integer]
prefixModulo = scanl update 1
    where update pl (pr, _) = (pl * (fromIntegral $ pr + 1)) `mod` moduloM1
suffixModulo = scanr update 1
    where update (pl, _) pr = ((fromIntegral $ pl + 1) * pr) `mod` moduloM1

modPow, modMul :: Integer -> Integer -> Integer
modPow a 0 = 1
modPow a n | even n    = c
           | otherwise = a `modMul` c
           where b = a `modPow` (n `div` 2)
                 c = b `modMul` b
modMul a b = (a * b) `mod` modulo

solve :: [Integer] -> Integer
solve ps = foldr modMul 1 $ zipWith3 calc ls pm sm
    where ls = getLambda ps
          pm = prefixModulo ls
          sm = tail $ suffixModulo ls

          calc :: (Int, Integer) -> Integer -> Integer -> Integer
          calc (l, p) pref suff = foldr modMul 1 powers
              where s = (pref * suff) `mod` moduloM1
                    m = modPow p s
                    powers = take (l + 1) $ iterate (`modMul` m) 1

type Tokenizer = State [Int]

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

nextInt :: Tokenizer Int
nextInt = state $ \(s:ss) -> (s, ss)

nextInteger :: Tokenizer Integer
nextInteger = state $ \(s:ss) -> (fromIntegral s, ss)

go :: Tokenizer Integer
go = do
  n <-  nextInt
  ps <- replicateM n nextInteger
  return $ solve ps

main :: IO ()
main = do
  input <- liftM (map parseInt . L.words) L.getContents
  print $ evalState go input

module Main where

import Control.Monad
import Control.Monad.State
import Data.List (group, sort)
import Data.Maybe (fromJust)
import Debug.Trace (trace)
import Data.Word (Word64)
import Text.Printf (printf)
import qualified Data.ByteString.Lazy.Char8 as L

modulo, moduloM1 :: Word64
modulo = 1000000000 + 7
moduloM1 = modulo - 1

getLambda :: [Word64] -> [(Int, Word64)]
getLambda = map toPair . group . sort
    where toPair ps = (length ps, head ps)

prefixModulo, suffixModulo :: [(Int, Word64)] -> [Word64]
prefixModulo = scanl update 1
    where update pl (pr, _) = (pl * (fromIntegral $ pr + 1)) `mod` moduloM1
suffixModulo = scanr update 1
    where update (pl, _) pr = ((fromIntegral $ pl + 1) * pr) `mod` moduloM1

modPow, modMul :: Word64 -> Word64 -> Word64
modPow a 0 = 1
modPow a n | even n    = c
           | otherwise = a `modMul` c
           where b = a `modPow` (n `div` 2)
                 c = b `modMul` b
modMul a b = (a * b) `mod` modulo

solve :: [Word64] -> Word64
solve ps = foldr modMul 1 $ zipWith3 calc ls pm sm
    where ls = getLambda ps
          pm = prefixModulo ls
          sm = tail $ suffixModulo ls

          calc :: (Int, Word64) -> Word64 -> Word64 -> Word64
          calc (l, p) pref suff = foldr modMul 1 powers
              where s = (pref * suff) `mod` moduloM1
                    m = modPow p s
                    powers = take (l + 1) $ iterate (`modMul` m) 1

type Tokenizer = State [Int]

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

nextInt :: Tokenizer Int
nextInt = state $ \(s:ss) -> (s, ss)

nextWord64 :: Tokenizer Word64
nextWord64 = state $ \(s:ss) -> (fromIntegral s, ss)

go :: Tokenizer Word64
go = do
  n <-  nextInt
  ps <- replicateM n nextWord64
  return $ solve ps

main :: IO ()
main = do
  input <- liftM (map parseInt . L.words) L.getContents
  print $ evalState go input

module Main where

import Control.Monad
import Control.Monad.State
import Data.List (group, sort)
import Data.Maybe (fromJust)
import Debug.Trace (trace)
import Text.Printf (printf)
import qualified Data.ByteString.Lazy.Char8 as L

modulo, moduloM1 :: Int
modulo = 1000000000 + 7
moduloM1 = modulo - 1

getLambda :: [Int] -> [(Int, Int)]
getLambda = map toPair . group . sort
    where toPair ps = (length ps, head ps)

prefixModulo, suffixModulo :: [(Int, Int)] -> [Int]
prefixModulo = scanl update 1
    where update pl (pr, _) = (pl * (pr + 1)) `mod` moduloM1
suffixModulo = scanr update 1
    where update (pl, _) pr = ((pl + 1) * pr) `mod` moduloM1

modPow, modMul :: Int -> Int -> Int
modPow a 0 = 1
modPow a n | even n    = c
           | otherwise = a `modMul` c
           where b = a `modPow` (n `div` 2)
                 c = b `modMul` b
modMul a b = (a * b) `mod` modulo

solve :: [Int] -> Int
solve ps = foldr modMul 1 $ zipWith3 calc ls pm sm
    where ls = getLambda ps
          pm = prefixModulo ls
          sm = tail $ suffixModulo ls

          calc :: (Int, Int) -> Int -> Int -> Int
          calc (l, p) pref suff = foldr modMul 1 powers
              where s = (pref * suff) `mod` moduloM1
                    m = modPow p s
                    powers = take (l + 1) $ iterate (`modMul` m) 1

type Tokenizer = State [Int]

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

nextInt :: Tokenizer Int
nextInt = state $ \(s:ss) -> (s, ss)

go :: Tokenizer Int
go = do
  n <-  nextInt
  ps <- replicateM n nextInt
  return $ solve ps

main :: IO ()
main = do
  input <- liftM (map parseInt . L.words) L.getContents
  print $ evalState go input


President of Berland has a very vast office-room, where, apart from him, work his subordinates. Each subordinate, as well as President himself, has his own desk of a unique colour. Each desk is rectangular, and its sides are parallel to the office walls. One day President decided to establish an assembly, of which all his deputies will be members. Unfortunately, he does not remember the exact amount of his deputies, but he remembers that the desk of each his deputy is adjacent to his own desk, that is to say, the two desks (President's and each deputy's) have a common side of a positive length.The office-room plan can be viewed as a matrix with n rows and m columns. Each cell of this matrix is either empty, or contains a part of a desk. An uppercase Latin letter stands for each desk colour. The «period» character («.») stands for an empty cell.

The first line contains two separated by a space integer numbers n, m (1 ≤ n, m ≤ 100) — the length and the width of the office-room, and c character — the President's desk colour. The following n lines contain m characters each — the office-room description. It is guaranteed that the colour of each desk is unique, and each desk represents a continuous subrectangle of the given matrix. All colours are marked by uppercase Latin letters.

Print the only number — the amount of President's deputies.

module Main where

import Control.Monad
import Data.Array.Unboxed
import Data.Ix
import Data.List
import qualified Data.Set as Set

main = do
    (n, m, ch) <- do
        [n, m, ch] <- words `liftM` getLine
        return (read n, read m, head ch)

    board <- ( listArray ((1,1), (n,m)) . join ) `liftM` replicateM n getLine :: IO (UArray (Int,Int) Char)

    let set = foldl' (\set (r,c) ->
                foldl' (\set (r1,c1,r2,c2) ->
                        let put r1 c1 r2 c2 set =
                                if board ! (r1,c1) == ch
                                    then Set.insert ( board ! (r2,c2) ) set
                                    else set
                        in if valid r1 c1 && valid r2 c2
                            then put r1 c1 r2 c2 $ put r2 c2 r1 c1 set
                            else set
                    ) set [(r,c,r,c+1),(r,c,r+1,c)]
            ) Set.empty $ range ((1,1),(n,m))
        set' = Set.delete '.' $ Set.delete ch set
        valid r c = 1 <= r && r <= n && 1 <= c && c <= m

    --putStrLn $ show board
    --putStrLn $ show set
    putStrLn $ show $ Set.size set'

import Data.Array
import Data.List
import Data.Functor
import Control.Monad

type Room = Array (Int, Int) Color
type Color = Char

countDepties :: Color -> Room -> Int -> Int -> Int
countDepties c room mx my = length $ adjacentTo c room mx my

adjacentTo :: Color -> Room -> Int -> Int -> [Color]
adjacentTo c m mx my = nub $ concatMap f [(x, y) | x <- [0..mx], y <- [0..my]]
  where
    f (x, y) | m ! (x, y) /= c = []
             | otherwise = filter (\d -> d /='.' && d /= c) $ map (m !) $
                up ++ down ++ left ++ right
      where
        up = if y > 0 then [(x, y - 1)] else []
        down = if y < my then [(x, y + 1)] else []
        left = if x > 0 then [(x - 1, y)] else []
        right = if x < mx then [(x + 1, y)] else []

main = do
    n':m':c':_ <- words <$> getLine
    let n = read n' - 1
        m = read m' - 1
        c = head c'
    is <- fmap concat $ forM [0..n] $ \y -> do
            s <- getLine :: IO [Char]
            return $ zip [(x, y) | x <- [0..m]] s
    let arr = array ((0, 0), (m, n)) is
    print $ countDepties c arr m n

import Array
import Data.Set
import Monad (liftM)
import Prelude hiding (filter)

parseFirstLine :: String -> (Int, Int, Char)
parseFirstLine line  =  case words line of
    [w1, w2, w3]  ->  (read w1, read w2, head w3)

parsePlane :: (Int, Int) -> [String] -> Array (Int, Int) Char
parsePlane (n, m) lines  =  accumArray (flip const) '.' ((0, 0), (n+1, m+1))
    [((i,j), lines !! (i-1) !! (j-1)) | i <- [1..n], j <- [1..m]]

solve :: (Int, Int) -> Char -> Array (Int, Int) Char -> Int
solve (n, m) c array  =  size . fromList $ list
  where
    list  =  [array ! (i, j) | i <- [1..n], j <- [1..m],
        array ! (i,j) /= '.',
        array ! (i,j) /= c,
        any (\(di, dj) -> array ! (i+di,j+dj) == c) [(0,1),(1,0),(0,-1),(-1,0)]]

main :: IO ()
main  =  do
    (n, m, c)  <-  liftM parseFirstLine getLine
    plane  <-  liftM (parsePlane (n, m) . take n . lines) getContents
    print $ solve (n, m) c plane

import Data.Set (Set, (\\))
import qualified Data.Set as Set
import Control.Monad
import Data.Array.IArray

neighbors ::  Array (Int, Int) Char -> (Int, Int) -> [(Int, Int)]
neighbors arr (r, c) = let try = [(r+1, c), (r-1, c), (r, c+1), (r, c-1)] in
  filter (inRange $ bounds arr) try

solve :: Array (Int, Int) Char -> Char -> Int
solve arr boss = Set.size . (\\ Set.fromList ['.', boss]) . Set.fromList . map (arr!) . concatMap (neighbors arr) . filter ((== boss) . (arr !)) . range $ bounds arr

main = do
  [r, _, color] <- words <$> getLine
  let numRows = read r
  grid <- replicateM numRows getLine
  let arr = listArray ((0, 0), (pred numRows, pred . length $ head grid)) $ join grid

  print $ solve arr (head color)
  return ()

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

count :: Array (Int, Int) Char -> Char -> String
count a c = show . length . group . sort $ do
  let b = bounds a
  idx@(y, x) <- range b
  guard $ a ! idx == c
  idx' <- [(y + 1, x), (y - 1,x), (y, x + 1), (y, x - 1)]
  guard $ b `inRange` idx'
  let c' = a ! idx'
  guard $ c' /= '.'
  guard $ c' /= c
  return c'

solve :: [String] -> [String]
solve = fmap return $ do
  [as, bs, cs] <- words . head
  let n = read as ; m = read bs ; c = head cs
  xs <- concat . take n . drop 1
  let a = listArray ((1, 1), (n, m)) xs
  return $ count a c

main = interact $ unlines . solve . lines

import Data.Char
import Data.List
import Data.Array.Unboxed
main = do
    [n', m', l'] <- words `fmap` getLine
    let color = head l'
        [n, m] = map read [n', m']
    строки <- mapM (\_ -> (\s' -> let s = take m s' in (any (==color) s, s))
                `fmap` getLine) [1..n]
    let строкиБосса = map fst $ filter snd $ zip [1..] $ map fst строки
        матр = listArray ((1,1),(n, m)) $ concat $ map snd строки :: UArray (Int, Int) Char
        (минХ, максХ) = (minimum строкиБосса, maximum строкиБосса)
        (минУ, максУ) = (minimum a, maximum a) where
            a = filter (\i->(==color) $ (матр!(минХ, i))) [1..m]
        allx = [минХ..максХ]
        ally = [минУ..максУ]
        all = (if минХ > 1  then [(минХ  - 1, i) | i <- ally] else []) ++
              (if максХ < n then [(максХ + 1, i) | i <- ally] else []) ++
              (if минУ > 1  then [(i, минУ  - 1) | i <- allx] else []) ++
              (if максУ < m then [(i, максУ + 1) | i <- allx] else [])
        границы = map (матр!) all
    putStrLn $ show $ length $ nub $ filter isUpper границы

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

count :: Array (Int, Int) Char -> Char -> String
count a c = show . length . group . sort $ do
      let b = bounds a
      (x, y) <- range b
      guard $ a ! (x, y) == c
      idx' <- [(x+1, y), (x-1, y), (x, y-1), (x, y+1)]
      guard $ inRange b idx'
      let c' = a ! idx'
      guard $ c' /= '.' && c' /= c
      return c'

solve :: [String] -> [String]
solve = fmap return $ do
      [nn, mm, cc] <- words . head
      let n = read nn; m = read mm; c = head cc
      xs <- concat . take n . tail
      let a = listArray ((1,1), (n,m)) xs
      return $ count a c

main = interact $ unlines . solve . lines

module Main where

import Data.Array.IArray (listArray, (!), bounds, indices)
import Data.Array.Unboxed (UArray)
import Data.List (sort, group)
import Data.Ix (inRange)
import Control.Monad (replicateM)

type Grid = UArray (Int, Int) Char

solve :: Grid -> Char -> Int
solve gr c = count . filter isViceTable $ concatMap around tablePos
  where
    tablePos = filter (\i -> gr ! i == c) (indices gr)
    isViceTable cc = cc /= c && cc /= '.'
    count = length . group . sort
    around (x, y) = map (gr !) $ filter (inRange $ bounds gr) [ (x + 1, y), (x - 1, y), (x, y + 1), (x, y - 1) ]

getGrid :: (Int, Int) -> IO Grid
getGrid (n, m) = do
  lines <- replicateM n getLine
  pure $ listArray ((1,1), (n, m)) (concat lines)

main :: IO ()
main = do
  [n, m, c] <- words <$> getLine
  grid <- getGrid (read n, read m)
  print $ solve grid (head c)

module Main where

import Control.Monad
import Data.Array.Unboxed
import Data.Ix
import Data.List
import qualified Data.Set as Set

main = do
    (n, m, ch) <- do
        [n, m, ch] <- words `liftM` getLine
        return (read n, read m, head ch)

    board <- ( listArray ((1,1), (n,m)) . join ) `liftM` replicateM n getLine :: IO (UArray (Int,Int) Char)

    let set = foldl' (\set (r,c) ->
                foldl' (\set (r1,c1,r2,c2) ->
                        let put r1 c1 r2 c2 set =
                                if board ! (r1,c1) == ch
                                    then Set.insert ( board ! (r2,c2) ) set
                                    else set
                        in put r1 c1 r2 c2 $ put r2 c2 r1 c1 set
                    ) set [(r-1,c-1,r-1,c)
                    ,(r-1,c,r,c)
                    ,(r,c,r,c-1)
                    ,(r,c-1,r-1,c-1)
                    ]
            ) Set.empty $ range ((2,2),(n,m))
        set' = Set.delete '.' $ Set.delete ch set

    --putStrLn $ show board
    --putStrLn $ show set
    putStrLn $ show $ Set.size set'

import Data.Char
import Data.List
import Data.Array.Unboxed
main = do
    [n', m', l'] <- words `fmap` getLine
    let color = head l'
        [n, m] = map read [n', m']
    строки <- mapM (\_ -> (\s' -> let s = take m s' in (any (==color) s, s))
                `fmap` getLine) [1..n]
    let строкиБосса = map fst $ filter snd $ zip [1..] $ map fst строки
        матр = listArray ((1,1),(n, m)) $ concat $ map snd строки :: UArray (Int, Int) Char
        (минХ, максХ) = (minimum строкиБосса, maximum строкиБосса)
        (минУ, максУ) = (minimum a, maximum a) where
            a = filter (\i->(==color) $ (матр!(минХ, i))) [1..m]
        allx = [минХ..максХ]
        ally = [минУ..максУ]
        all = (if минХ > 1  then [(минХ  - 1, i) | i <- ally] else []) ++
              (if максХ < n then [(максХ + 1, i) | i <- ally] else []) ++
              (if минУ < 1  then [(i, минУ  - 1) | i <- allx] else []) ++
              (if максУ < m then [(i, максУ + 1) | i <- allx] else [])
        границы = map (матр!) all
    putStrLn $ show $ length $ nub $ filter isUpper границы

module Main where

import Data.Array.IArray (listArray, (!), bounds, indices)
import Data.Array.Unboxed (UArray)
import Data.List (sort, group)
import Data.Ix (inRange)

type Grid = UArray (Int, Int) Char

solve :: Grid -> Char -> Int
solve gr c = count . filter isViceTable $ concatMap around tablePos
  where
    tablePos = filter (\i -> gr ! i == c) (indices gr)
    isViceTable cc = cc /= c && cc /= '.'
    count = length . group . sort
    around (x, y) = map (gr !) $ filter (inRange $ bounds gr) [ (x + 1, y), (x - 1, y), (x, y + 1), (x, y - 1) ]

main :: IO ()
main = do
  [n, m, c] <- words <$> getLine
  grid <- listArray ((1, 1), (read n, read m)) <$> getContents :: IO Grid
  print $ solve grid (head c)


The only difference between problems C1 and C2 is that all values in input of problem C1 are distinct (this condition may be false for problem C2).You are given a sequence $$$a$$$ consisting of $$$n$$$ integers. All these integers are distinct, each value from $$$1$$$ to $$$n$$$ appears in the sequence exactly once.You are making a sequence of moves. During each move you must take either the leftmost element of the sequence or the rightmost element of the sequence, write it down and remove it from the sequence. Your task is to write down a strictly increasing sequence, and among all such sequences you should take the longest (the length of the sequence is the number of elements in it).For example, for the sequence $$$[2, 1, 5, 4, 3]$$$ the answer is $$$4$$$ (you take $$$2$$$ and the sequence becomes $$$[1, 5, 4, 3]$$$, then you take the rightmost element $$$3$$$ and the sequence becomes $$$[1, 5, 4]$$$, then you take $$$4$$$ and the sequence becomes $$$[1, 5]$$$ and then you take $$$5$$$ and the sequence becomes $$$[1]$$$, the obtained increasing sequence is $$$[2, 3, 4, 5]$$$).

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

In the first line of the output print $$$k$$$ — the maximum number of elements in a strictly increasing sequence you can obtain. In the second line print a string $$$s$$$ of length $$$k$$$, where the $$$j$$$-th character of this string $$$s_j$$$ should be 'L' if you take the leftmost element during the $$$j$$$-th move and 'R' otherwise. If there are multiple answers, you can print any.

NoteThe first example is described in the problem statement.

import qualified Data.Sequence as S
import Data.Maybe
import Data.Monoid

sHead :: S.Seq a -> Maybe a
sHead s =case S.viewl s of
	((S.:<) n _) -> Just n
	_-> Nothing

sLast :: S.Seq a -> Maybe a
sLast s =case S.viewr s of
	((S.:>) _ n ) -> Just n
	_-> Nothing

sTail :: S.Seq a -> S.Seq a
sTail s = case S.viewl s of
	((S.:<) _ n) -> n
	_ -> S.empty

sInit :: S.Seq a -> S.Seq a
sInit s = case S.viewr s of
	((S.:>) n _) -> n
	_ -> S.empty

sHeadUnsafe :: S.Seq a ->  a
sHeadUnsafe s = fromMaybe undefined $ sHead s

sLastUnsafe :: S.Seq a ->  a
sLastUnsafe s = fromMaybe undefined $ sLast s

type Status a = (a,[Char])
type Situation a = (Status a,S.Seq a)

step :: Ord a => Situation a -> Either ([Char]) (Situation a)
step ((curr,directions),S.Empty) = Left directions
step ((curr,directions),seq)
	|curr < seqHead && curr < seqLast =
	if seqHead <= seqLast
	then
		l
	else
		r
	|curr < seqHead = l
	|curr < seqLast = r
	|otherwise = Left directions
	where
		seqHead= sHeadUnsafe seq
		seqLast= sLastUnsafe seq
		l = Right ((seqHead, ('L': directions)), sTail seq)
		r = Right ((seqLast, ('R':directions) ), sInit seq)

steps ::Ord a => Situation a -> [Char]
steps sit =
	case step sit of
		Left dl -> reverse dl
		Right s -> steps s

main = do
	n <- getLine
	l <- fmap ((map read).words) getLine
	let sol = steps $ ((0,""),S.fromList l)
	putStrLn $ show $ length sol
	putStrLn sol

--prewritten code: https://github.com/antma/algo
{-# LANGUAGE BangPatterns, Safe #-}
{-# Options_GHC -O2 #-}
import Data.ByteString.Builder
import Data.Monoid
import System.IO
import qualified Data.ByteString.Char8 as C
import Data.Time (diffTimeToPicoseconds, utctDayTime, getCurrentTime)
import Data.Char
import qualified Data.Array.Unboxed as UA

getSeed = return . fromInteger . (`mod` 999983) . diffTimeToPicoseconds . utctDayTime =<< getCurrentTime :: IO Int

ru, ri :: C.ByteString -> Int

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

solve :: [Int] -> Builder
solve (n:a) = intDec (C.length ans) <> char7 '\n' <>  byteString ans <> char7 '\n'
  where
    b = take n a
    x = UA.listArray (1, n) b :: UA.UArray Int Int
    loop i j last r
      | i > j = r
      | null l = r
      | d == 'L' = loop (succ i) j v (d:r)
      | d == 'R' = loop i (pred j) v (d:r)
      where
        xi = x UA.! i
        xj = x UA.! j
        l = filter ( (last <  ) . fst) [(xi, 'L'), (xj, 'R')]
        (v, d) = minimum l
    ans = C.reverse $ C.pack $ loop 1 n minBound []

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

import Data.Sequence as S
import Data.Maybe
sHead :: Seq a -> Maybe a
sHead s =case viewl s of
	(n :< _) -> Just n
	_-> Nothing

sLast :: Seq a -> Maybe a
sLast s =case viewr s of
	(_ :> n) -> Just n
	_-> Nothing

sTail :: Seq a -> Seq a
sTail s = case viewl s of
	(_ :< n) -> n
	_ -> empty

sInit :: Seq a -> Seq a
sInit s = case viewr s of
	(n :> _) -> n
	_ -> empty

sHeadUnsafe :: Seq a ->  a
sHeadUnsafe s = fromMaybe undefined $ sHead s

sLastUnsafe :: Seq a ->  a
sLastUnsafe s = fromMaybe undefined $ sLast s

type Status a = (a,[Char])
type Situation a = (Status a,Seq a)

step :: Ord a => Situation a -> Either [Char] (Situation a)
step ((curr,directions),Empty) = Left directions
step ((curr,directions),seq)
	|curr < seqHead && curr < seqLast =
	if seqHead <= seqLast
	then
		Right ((seqHead, directions ++ "L" ), sTail seq)
	else
		Right ((seqLast, directions ++ "R" ), sInit seq)
	|curr < seqHead = Right ((seqHead, directions ++ "L" ), sTail seq)
	|curr < seqLast = Right ((seqLast, directions ++ "R" ), sInit seq)
	|otherwise = Left directions
	where
		seqHead= sHeadUnsafe seq
		seqLast= sLastUnsafe seq

steps ::Ord a => Situation a -> [Char]
steps sit =
	case step sit of
		Left l -> l
		Right s -> steps s

main = do
	n <- getLine
	l <- fmap ((map read).words) getLine
	putStrLn $ steps $ ((0,""),S.fromList l)


You are given an array of integers $$$a_1,a_2,\ldots,a_n$$$. Find the maximum possible value of $$$a_ia_ja_ka_la_t$$$ among all five indices $$$(i, j, k, l, t)$$$ ($$$i<j<k<l<t$$$).

The input consists of multiple test cases. The first line contains an integer $$$t$$$ ($$$1\le t\le 2 \cdot 10^4$$$) — the number of test cases. The description of the test cases follows. The first line of each test case contains a single integer $$$n$$$ ($$$5\le n\le 10^5$$$) — the size of the array. The second line of each test case contains $$$n$$$ integers $$$a_1,a_2,\ldots,a_n$$$ ($$$-3\times 10^3\le a_i\le 3\times 10^3$$$) — given array. It's guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$2\cdot 10^5$$$.

For each test case, print one integer — the answer to the problem.

NoteIn the first test case, choosing $$$a_1,a_2,a_3,a_4,a_5$$$ is a best choice: $$$(-1)\cdot (-2) \cdot (-3)\cdot (-4)\cdot (-5)=-120$$$.In the second test case, choosing $$$a_1,a_2,a_3,a_5,a_6$$$ is a best choice: $$$(-1)\cdot (-2) \cdot (-3)\cdot 2\cdot (-1)=12$$$.In the third test case, choosing $$$a_1,a_2,a_3,a_4,a_5$$$ is a best choice: $$$(-1)\cdot 0\cdot 0\cdot 0\cdot (-1)=0$$$.In the fourth test case, choosing $$$a_1,a_2,a_3,a_4,a_6$$$ is a best choice: $$$(-9)\cdot (-7) \cdot (-5)\cdot (-3)\cdot 1=945$$$.

{-# LANGUAGE OverloadedStrings #-}
import Control.Monad
import Control.Applicative
import Data.Int
import Data.Maybe
import Data.List
import Data.Functor
import Data.Bool
import Data.Array.Unboxed as UA
import qualified Data.ByteString.Char8 as B8
import Text.Printf

-- import Debug.Trace

-- debug = flip trace

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

readInt64B8 :: B8.ByteString -> Int64
readInt64B8 = fromIntegral . fst . fromJust . B8.readInteger

cases :: [(Int, Int, String)]
cases = [
    (0, 5, "max"),
    (1, 4, "min"),
    (2, 3, "max"),
    (3, 2, "min"),
    (4, 1, "max"),
    (5, 0, "min")]

solve :: Int -> [Int64] -> Int64
solve n as = foldr1 max $ solvedCases
--        `debug` (show solvedCases)
    where
        solvedCases = catMaybes $ map solveCase cases

        positiveAs = sort $ filter (> 0) as
        negativeAs = reverse . sort $ filter (< 0) as
        zeros = filter (== 0) as

        solveCase (minCnt, maxCnt, ordString)
            | ((length negativeAs < minCnt) || (length positiveAs < maxCnt)) && (length zeros > 0) = Just 0
            | (length negativeAs < minCnt) || (length positiveAs < maxCnt) = Nothing
            | ordString == "max" = Just . foldr1 (*) $ ((take minCnt $ reverse negativeAs) ++ (take maxCnt $ reverse positiveAs))
            | ordString == "min" = Just . foldr1 (*) $ ((take minCnt negativeAs) ++ (take maxCnt positiveAs))
            | otherwise = Nothing

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    forM_ [1..t] $ \_ -> do
        n <- B8.getLine <&> readIntB8
        as <- B8.getLine <&> B8.words <&> map readInt64B8
        let answer = solve n as
        printf "%s\n" $ show answer

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

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

getIntegers :: IO [Integer]
getIntegers = map (fst . fromJust . C.readInteger) . C.words <$> C.getLine

main :: IO ()
main = do
  [caseNum] <- getInts
  forM_ [1..caseNum] $ \_ -> do
    _ <- getInts
    as <- getIntegers
    let nz = length $ filter (==0) as
        (ps', ns') = partition (>0) $ filter (/=0) as
        [ps, ns] = [reverse $ sort ps', sort ns']
        [lp, ln] = map length [ps, ns]
        f1 = if lp + ln < 5 then 0 else f2
        f2 = if lp == 0 || lp + ln == 5 && even lp then (if nz > 0 then 0 else product $ take 5 $ reverse $ sort $ map negate ps ++ ns) else f3
        f3 = maximum $ map (\xs -> if length xs < 5 then 0 else product xs) [take 5 ps, take 3 ps ++ take 2 ns, head ps : take 4 ns]
    printf "%d\n" f1

import Control.Monad
import Data.Int

step :: [(Int64, Int64)] -> [Int64] -> [(Int64, Int64)]
step ps ws = let
  rs = do
    ((pL, pR), w) <- zip ps ws
    let
      npL = w * pL
      npR = w * pR
    pure (min npL npR, max npL npR)
  rangeUnion (p, q) (x, y) = (min p x, max q y)
  in  tail $ scanl rangeUnion (maxBound, minBound) rs

solve :: [Int64] -> Int -> Int64
solve _ 0 = 1
solve a k = go (repeat (1, 1)) a k  where
  go sc _ 0 = snd $ last sc
  go sc at kr = go (step sc at) (tail at) (kr - 1)

main :: IO ()
main = do
  t <- read <$> getLine
  replicateM_ t $ do
    _nStr <- getLine
    a <- map read . words <$> getLine
    print $ solve a 5


You are given a set Y of n distinct positive integers y1, y2, ..., yn.Set X of n distinct positive integers x1, x2, ..., xn is said to generate set Y if one can transform X to Y by applying some number of the following two operation to integers in X:  Take any integer xi and multiply it by two, i.e. replace xi with 2·xi.  Take any integer xi, multiply it by two and add one, i.e. replace xi with 2·xi + 1. Note that integers in X are not required to be distinct after each operation.Two sets of distinct integers X and Y are equal if they are equal as sets. In other words, if we write elements of the sets in the array in the increasing order, these arrays would be equal.Note, that any set of integers (or its permutation) generates itself.You are given a set Y and have to find a set X that generates Y and the maximum element of X is mininum possible.

The first line of the input contains a single integer n (1 ≤ n ≤ 50 000) — the number of elements in Y. The second line contains n integers y1, ..., yn (1 ≤ yi ≤ 109), that are guaranteed to be distinct.

Print n integers — set of distinct integers that generate Y and the maximum element of which is minimum possible. If there are several such sets, print any of them.

{-
██╗  ██╗ █████╗ ███████╗██╗  ██╗███████╗██╗     ██╗         ███████╗████████╗██╗    ██╗
██║  ██║██╔══██╗██╔════╝██║ ██╔╝██╔════╝██║     ██║         ██╔════╝╚══██╔══╝██║    ██║
███████║███████║███████╗█████╔╝ █████╗  ██║     ██║         █████╗     ██║   ██║ █╗ ██║
██╔══██║██╔══██║╚════██║██╔═██╗ ██╔══╝  ██║     ██║         ██╔══╝     ██║   ██║███╗██║
██║  ██║██║  ██║███████║██║  ██╗███████╗███████╗███████╗    ██║        ██║   ╚███╔███╔╝
╚═╝  ╚═╝╚═╝  ╚═╝╚══════╝╚═╝  ╚═╝╚══════╝╚══════╝╚══════╝    ╚═╝        ╚═╝    ╚══╝╚══╝

                                    $$\                  $$$$$$\  $$\         $$\   $$$$$$\        $$\      $$\   $$\ $$\
                                    \__|                $$  __$$\ $$ |      $$$$ | $$  __$$\       $$ |     $$ |  $$ |$$ |
 $$$$$$$\  $$$$$$\   $$$$$$\        $$\ $$$$$$$\        \__/  $$ |$$ |  $$\ \_$$ | $$ /  $$ |      $$ |     $$ |  $$ |$$ |
$$  _____|$$  __$$\ $$  __$$\       $$ |$$  __$$\        $$$$$$  |$$ | $$  |  $$ | \$$$$$$$ |      $$ |     $$ |  $$ |$$ |
$$ /      $$ /  $$ |$$ /  $$ |      $$ |$$ |  $$ |      $$  ____/ $$$$$$  /   $$ |  \____$$ |      $$ |     $$ |  $$ |$$ |
$$ |      $$ |  $$ |$$ |  $$ |      $$ |$$ |  $$ |      $$ |      $$  _$$<    $$ | $$\   $$ |      $$ |     $$ |  $$ |$$ |
\$$$$$$$\ $$$$$$$  |$$$$$$$  |      $$ |$$ |  $$ |      $$$$$$$$\ $$ | \$$\ $$$$$$\\$$$$$$  |      $$$$$$$$\\$$$$$$  |$$$$$$$$\
 \_______|$$  ____/ $$  ____/       \__|\__|  \__|      \________|\__|  \__|\______|\______/       \________|\______/ \________|
          $$ |      $$ |
          $$ |      $$ |
          \__|      \__|
-}

{-# LANGUAGE ScopedTypeVariables #-}
module Main where

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

main :: IO ()
main = do
    line <- getLine >> getLine
    let nums :: [Int] = sortBy (flip compare) . map read . words $ line
    putStrLn . unwords . map show . S.toDescList . solve . S.fromDescList $ nums

possibilities :: Int -> [Int]
possibilities n | n == 1    = [1]
                | even n    = n : possibilities (n     `div` 2)
                | otherwise = n : possibilities ((n-1) `div` 2)

reduce :: S.Set Int -> Maybe (S.Set Int)
reduce  xs           = maxNonMember >>= (\e -> Just . S.insert e . S.delete maxElem $ xs) where
        maxElem      = S.findMax xs
        maxNonMember = find (`S.notMember` xs) $ possibilities maxElem

solve :: S.Set Int -> S.Set Int
solve xs = case reduce xs of
    Nothing -> xs
    Just ys -> solve ys

{-# LANGUAGE ScopedTypeVariables #-}
module Main where

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

main :: IO ()
main = do
    line <- getLine >> getLine
    let nums :: [Int] = sortBy (flip compare) . map read . words $ line
    putStrLn . unwords . map show . S.toDescList . solve . S.fromDescList $ nums

-- possibilities :: Int -> [Int]
-- possibilities = possibilities' []

-- possibilities' :: [Int] -> Int-> [Int]
-- possibilities' acc n | n == 1    = reverse acc
--                      | even n    = possibilities' (n `div` 2 : acc) (n `div` 2)
--                      | otherwise = possibilities' ((n-1) `div` 2 : acc) ((n-1) `div` 2)
possibilities :: Int -> [Int]
possibilities n | n == 1    = [1]
                | even n    = n : possibilities (n     `div` 2)
                | otherwise = n : possibilities ((n-1) `div` 2)

reduce :: S.Set Int -> Maybe (S.Set Int)
-- reduce xs = case maxNonMember of
--     Nothing -> Nothing
--     Just e -> Just $ S.insert e $ S.delete maxElem xs
reduce xs = maxNonMember >>= (\e -> Just . S.insert e $ S.delete maxElem xs)
    where
        maxElem = S.findMax xs
        maxNonMember = find (`S.notMember` xs) $ possibilities maxElem

solve :: S.Set Int -> S.Set Int
solve xs = case reduce xs of
    Nothing -> xs
    Just ys -> solve ys

{-# LANGUAGE ScopedTypeVariables #-}
module Main where

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

main :: IO ()
main = do
    line2 <- getLine >> getLine
    let nums :: [Int] = sortBy (flip compare) $ map read $ words line2
    putStrLn $ unwords $ map show $ S.toDescList $ solve $ S.fromDescList nums

possibilities :: Int -> [Int]
possibilities = possibilities' []

possibilities' :: [Int] -> Int-> [Int]
possibilities' acc n | n == 1    = reverse acc
                     | even n    = possibilities' (n `div` 2 : acc) (n `div` 2)
                     | otherwise = possibilities' ((n-1) `div` 2 : acc) ((n-1) `div` 2)

reduce :: S.Set Int -> Maybe (S.Set Int)
reduce xs = case maxNonMember of
    Nothing -> Nothing
    Just e -> Just $ S.insert e $ S.delete maxElem xs
    where
        maxElem = S.findMax xs
        maxNonMember = find (\x -> x `S.notMember` xs) $ possibilities maxElem

solve :: S.Set Int -> S.Set Int
solve xs = case reduce xs of
    Nothing -> xs
    Just ys -> solve ys

{-# OPTIONS_GHC -O2 #-}
{-# LANGUAGE BangPatterns #-}
import           Control.Applicative
import           Control.Monad
import qualified Data.ByteString.Char8 as B
import qualified Data.IntSet           as IS

main :: IO ()
main = do
  n <- readLn :: IO Int
  xs <- map readInt.B.words <$> B.getLine
  putStrLn.unwords.map show $ solve xs

solve :: [Int] -> [Int]
solve xs = go $ IS.fromList xs
  where
    go set = case filter (`IS.notMember`set') ms of
        (y:_) -> go $ IS.insert y set'
        [] -> IS.toList set
      where
        (m, set') = IS.deleteFindMax set
        ms = tail.takeWhile (>0) $ iterate (`quot`2) m

readInt :: B.ByteString -> Int
readInt bs=case B.readInt bs of{Just(n,_)->n;_->error$"readInt error : bs = "++show bs;}

import qualified Data.ByteString.Char8 as BS
import qualified Data.Set as S

readInt s = let Just (a, _) = BS.readInt s in a

main = BS.interact $ BS.unwords . map (BS.pack . show) . solve . map readInt . BS.words

solve (n:rest) = S.toList $ relax_all $ S.fromList $ take n rest
  where relax_all s = let rv = relax s in
          if rv > 0 then relax_all $ S.insert rv $ S.deleteMax s
          else s

relax s = relax_ $ S.findMax s
  where relax_ v = if S.notMember v s then v else relax_ $ v `div` 2

import qualified Data.ByteString.Char8 as BS
import qualified Data.Set as S

readInt s = let Just (a, _) = BS.readInt s in a

main = BS.interact $ BS.unwords . map (BS.pack . show) . solve . map readInt . BS.words

solve (n:rest) = S.toList $ relax_all $ S.fromList $ take n rest
  where relax_all s = let rv = relax s in
          if rv > 0 then S.insert rv $ S.deleteMax s
          else s

relax s = relax_ $ S.findMax s
  where relax_ v = if S.notMember v s then v else relax_ $ v `div` 2

import qualified Data.ByteString.Char8 as BS
import qualified Data.Set as S

readInt s = let Just (a, _) = BS.readInt s in a

main = BS.interact $ BS.unwords . map (BS.pack . show) . solve . map readInt . BS.words

solve (n:rest) = S.toList $ relax_all $ S.fromList $ take n rest
  where relax_all s = let rv = relax s in
          if rv > 0 then S.insert rv $ S.deleteMax s
          else s

relax s = relax_ $ S.findMax s
  where relax_ v = if S.member v s then v else relax_ $ v `div` 2