You are given a positive integer $$$n$$$. Since $$$n$$$ may be very large, you are given its binary representation.You should compute the number of triples $$$(a,b,c)$$$ with $$$0 \leq a,b,c \leq n$$$ such that $$$a \oplus b$$$, $$$b \oplus c$$$, and $$$a \oplus c$$$ are the sides of a non-degenerate triangle. Here, $$$\oplus$$$ denotes the bitwise XOR operation.You should output the answer modulo $$$998\,244\,353$$$.Three positive values $$$x$$$, $$$y$$$, and $$$z$$$ are the sides of a non-degenerate triangle if and only if $$$x+y>z$$$, $$$x+z>y$$$, and $$$y+z>x$$$.

The first and only line contains the binary representation of an integer $$$n$$$ ($$$0 < n < 2^{200\,000}$$$) without leading zeros. For example, the string 10 is the binary representation of the number $$$2$$$, while the string 1010 represents the number $$$10$$$.

Print one integer — the number of triples $$$(a,b,c)$$$ satisfying the conditions described in the statement modulo $$$998\,244\,353$$$.

NoteIn the first test case, $$$101_2=5$$$.  The triple $$$(a, b, c) = (0, 3, 5)$$$ is valid because $$$(a\oplus b, b\oplus c, c\oplus a) = (3, 6, 5)$$$ are the sides of a non-degenerate triangle.  The triple $$$(a, b, c) = (1, 2, 4)$$$ is valid because $$$(a\oplus b, b\oplus c, c\oplus a) = (3, 6, 5)$$$ are the sides of a non-degenerate triangle. The $$$6$$$ permutations of each of these two triples are all the valid triples, thus the answer is $$$12$$$.In the third test case, $$$11\,011\,111\,101\,010\,010_2=114\,514$$$. The full answer (before taking the modulo) is $$$1\,466\,408\,118\,808\,164$$$.

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems, MArray, Ix (range))
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.IntMap as IntMap
import Control.Monad.Trans.Class
import Data.Bits

mm = 998244353
type Domain = [Bool]
type CoDomain = Int
type Solver  = Domain -> IO CoDomain

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

printAns :: CoDomain -> IO ()
printAns = putStrLn . show

parse :: IO Domain
parse = do
  xs <- map (=='1') <$> getLine
  return xs

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

type Count = IOUArray (Int,Int) Int

ones :: Int -> Int
ones 0 = 0
ones 1 = 1
ones i
  | even i = ni
  | odd i = ni + 1
  where ni = ones $ i `div` 2

gi :: Int -> Int -> Int
gi i j = i * 8 + j

solve1 :: [Bool] -> IO Count
solve1 xs = do
    c1 <- newArray ((0, 0), (7, 7)) 0
    writeArray c1 (0,0) 1
    gogo c1 xs
    where
      gogo :: Count -> [Bool] -> IO Count
      gogo c1 xs = case xs of
        [] -> return c1
        (x:xs) -> do
          c2 <- newArray ((0, 0), (7, 7)) 0
          let gg = (go c1 c2 x)
          mapM_  gg indices
          gogo c2 xs
      indices = [(mask, i, j) | mask <-[0..7],i <- [0..7], j <- [0..7]]
      go ::
        Count
        -> Count
        -> Bool
        -> (Int -- mask
        ,   Int -- prefix less
        ,   Int )
        -> IO ()
      go c1 c2 isOne (mask, i, j)
        | isOne || (mask .&. i) == mask =
          do
            val1 <- readArray c1 (i,  j)
            val2 <- readArray c2 (ni, nj)
            writeArray c2 (ni, nj) (val1+val2 `mod` mm)
        | otherwise = return ()
          where
            vmask = 7 .&. (complement mask)
            ni = if isOne then i .|. vmask else i
            nj = case ones mask of
              1 -> j .|. mask
              2 -> j .|. vmask
              otherwise -> j

main :: IO ()
main = do
  res <- solve1 =<< parse
  printAns =<< (foldr (((`mod` mm).) . (+)) 0) <$> sequence (readArray res <$> [(i, 7) |i <- [0..7]])
  return ()

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems, MArray, Ix (range))
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.IntMap as IntMap
import Control.Monad.Trans.Class
import Data.Bits

mm = 998244353
type Domain = [Bool]
type CoDomain = Int
type Solver  = Domain -> IO CoDomain

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

printAns :: CoDomain -> IO ()
printAns = putStrLn . show

parse :: IO Domain
parse = do
  xs <- map (=='1') <$> getLine
  return xs

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

type Count = IOUArray (Int,Int) Int

ones :: Int -> Int
ones 0 = 0
ones 1 = 1
ones i
  | even i = ni
  | odd i = ni + 1
  where ni = ones $ i `div` 2

gi :: Int -> Int -> Int
gi i j = i * 8 + j

resetArray ::  Count -> IO ()
resetArray x = mapM_ (flip (writeArray x) 0) $ range ((0,0), (7,7))

solve1 :: [Bool] -> IO Count
solve1 xs = do
    c1 <- newArray ((0, 0), (7, 7)) 0
    writeArray c1 (0,0) 1
    gogo c1 xs
    where
      gogo :: Count -> [Bool] -> IO Count
      gogo c1 xs = case xs of
        [] -> return c1
        (x:xs) -> do
          c2 <- newArray ((0, 0), (7, 7)) 0
          mapM_ (go c1 c2 x) indices
          gogo c2 xs
      indices = [(mask, i, j) | mask <-[0..7],i <- [0..7], j <- [0..7]]
      go ::
        Count
        -> Count
        -> Bool
        -> (Int -- mask
        ,   Int -- prefix less
        ,   Int )
        -> IO ()
      go c1 c2 isOne (mask, i, j)
        | isOne || (mask .&. i) == mask =
          do
            val1 <- readArray c1 (i,  j)
            val2 <- readArray c2 (ni, nj)
            writeArray c2 (ni, nj) (val1+val2 `mod` mm)
        | otherwise = return ()
          where
            vmask = 7 .&. (complement mask)
            ni = if isOne then i .|. vmask else i
            nj = case ones mask of
              1 -> j .|. mask
              2 -> j .|. vmask
              otherwise -> j

main :: IO ()
main = do
  res <- solve1 =<< parse
  printAns =<< (foldr (((`mod` mm).) . (+)) 0) <$> sequence (readArray res <$> [(i, 7) |i <- [0..7]])
  return ()

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems, MArray, Ix (range))
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.IntMap as IntMap
import Control.Monad.Trans.Class
import Data.Bits

mm = 998244353
type Domain = [Bool]
type CoDomain = Int
type Solver  = Domain -> IO CoDomain

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

printAns :: CoDomain -> IO ()
printAns = putStrLn . show

parse :: IO Domain
parse = do
  xs <- map (=='1') <$> getLine
  return xs

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

type Count = IOUArray (Int,Int) Int

ones :: Int -> Int
ones 0 = 0
ones 1 = 1
ones i
  | even i = ni
  | odd i = ni + 1
  where ni = ones $ i `div` 2

gi :: Int -> Int -> Int
gi i j = i * 8 + j

resetArray ::  Count -> IO ()
resetArray x = mapM_ (flip (writeArray x) 0) $ range ((0,0), (7,7))

solve1 :: [Bool] -> IO Count
solve1 xs = do
    c1 <- newArray ((0, 0), (7, 7)) 0
    writeArray c1 (0,0) 1
    gogo c1 xs
    where
      gogo :: Count -> [Bool] -> IO Count
      gogo c1 xs = case xs of
        [] -> return c1
        (x:xs) -> do
          c2 <- newArray ((0, 0), (7, 7)) 0
          mapM_ (go c1 c2 x) indices
          resetArray c1
          gogo c2 xs
      indices = [(mask, i, j) | mask <-[0..7],i <- [0..7], j <- [0..7]]
      go ::
        Count
        -> Count
        -> Bool
        -> (Int -- mask
        ,   Int -- prefix less
        ,   Int )
        -> IO ()
      go c1 c2 isOne (mask, i, j)
        | isOne || (mask .&. i) == mask =
          do
            val1 <- readArray c1 (i,  j)
            val2 <- readArray c2 (ni, nj)
            writeArray c2 (ni, nj) (val1+val2 `mod` mm)
        | otherwise = return ()
          where
            vmask = 7 .&. (complement mask)
            ni = if isOne then i .|. vmask else i
            nj = case ones mask of
              1 -> j .|. mask
              2 -> j .|. vmask
              otherwise -> j

main :: IO ()
main = do
  res <- solve1 =<< parse
  printAns =<< (foldr (((`mod` mm).) . (+)) 0) <$> sequence (readArray res <$> [(i, 7) |i <- [0..7]])
  return ()

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems, MArray, Ix (range))
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.IntMap as IntMap
import Control.Monad.Trans.Class
import Data.Bits

mm = 998244353
type Domain = [Bool]
type CoDomain = Int
type Solver  = Domain -> IO CoDomain

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

printAns :: CoDomain -> IO ()
printAns = putStrLn . show

parse :: IO Domain
parse = do
  xs <- map (=='1') <$> getLine
  return xs

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

type Count = IOUArray (Int,Int) Int

ones :: Int -> Int
ones 0 = 0
ones 1 = 1
ones i
  | even i = ni
  | odd i = ni + 1
  where ni = ones $ i `div` 2

gi :: Int -> Int -> Int
gi i j = i * 8 + j

resetArray ::  Count -> IO ()
resetArray x = mapM_ (flip (writeArray x) 0) $ range ((0,0), (7,7))

solve1 :: [Bool] -> IO Count
solve1 xs = do
    c1 <- newArray ((0, 0), (7, 7)) 0
    c2 <- newArray ((0, 0), (7, 7)) 0
    writeArray c1 (0,0) 1
    gogo c1 c2 xs
    where
      gogo :: Count -> Count -> [Bool] -> IO Count
      gogo c1 c2 xs = case xs of
        [] -> return c1
        (x:xs) -> do
          mapM_ (go c1 c2 x)  indices
          resetArray c1
          gogo c2 c1 xs
      indices = [(mask, i, j) | mask <-[0..7],i <- [0..7], j <- [0..7]]
      go ::
        Count
        -> Count
        -> Bool
        -> (Int -- mask
        ,   Int -- prefix less
        ,   Int )
        -> IO ()
      go c1 c2 isOne (mask, i, j)
        | isOne || (mask .&. i) == mask =
          do
            val1 <- readArray c1 (i,  j)
            val2 <- readArray c2 (ni, nj)
            writeArray c2 (ni, nj) (val1+val2 `mod` mm)
        | otherwise = return ()
          where
            vmask = 7 .&. (complement mask)
            ni = if isOne then i .|. vmask else i
            nj = case ones mask of
              1 -> j .|. mask
              2 -> j .|. vmask
              otherwise -> j

main :: IO ()
main = do
  res <- solve1 =<< parse
  printAns =<< (foldr (((`mod` mm).) . (+)) 0) <$> sequence (readArray res <$> [(i, 7) |i <- [0..7]])
  return ()

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems, MArray)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.IntMap as IntMap
import Control.Monad.Trans.Class
import Data.Bits
import Data.Ix (Ix(range))

mm = 998244353
type Domain = [Bool]
type CoDomain = Int
type Solver  = Domain -> IO CoDomain

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

printAns :: CoDomain -> IO ()
printAns = putStrLn . show

parse :: IO Domain
parse = do
  xs <- map (=='1') <$> getLine
  return xs

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

type Count = IOUArray (Int, Int, Int) Int

ones :: Int -> Int
ones 0 = 0
ones 1 = 1
ones i
  | even i = ni
  | odd i = ni + 1
  where ni = ones $ i `div` 2

solve1 :: [Bool] -> IO Count
solve1 xs = do
    c <- newArray ((0, 0, 0), (length xs, 7, 7)) 0
    writeArray c (0,0,0) 1
    mapM_ (go c) $ indices xs
    return c
    where
      indices :: [Bool] -> [(Int, Bool, Int, Int, Int)]
      indices xs = [(k, x ,mask, i, j)
        | (k, x) <- zip [0..length xs-1] xs
        , mask <-[0..7]
        , i <- [0..7]
        , j <- [0..7]
        -- , x || (mask .&. i) == mask
         ]
      go ::
        Count
        -> (
          Int -- index for xs
        , Bool
        , Int -- mask
        ,  Int -- prefix less
        ,  Int) -- minor
        -> IO ()
      go c (k, isOne, mask, i, j)
          | isOne || (mask .&. i) == mask = do
            v1 <- readArray c (k, i, j)
            v2 <- readArray c (k+1, ni,nj)
            writeArray c (k+1,ni,nj) (v1+v2 `mod` mm)
          | otherwise = return ()
          where
            vmask = 7 .&. (complement mask)
            ni = if isOne then i .|. vmask else i
            nj = case ones mask of
              1 -> j .|. mask
              2 -> j .|. vmask
              otherwise -> j

a :: Integer
a = 2
main :: IO ()
main = do
  -- print (range ((0,0),(7,7)) )
  -- print $ 2 ^ 200000
  xs <- parse
  res <- solve1 xs
  printAns =<< (foldr (((`mod` mm).) . (+)) 0) <$> sequence (readArray res <$> [(length xs, i, 7) |i <- [0..7]])
  return ()

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems, MArray)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.IntMap as IntMap
import Control.Monad.Trans.Class
import Data.Bits
import Data.Ix (Ix(range))

mm = 998244353
type Domain = [Bool]
type CoDomain = Int
type Solver  = Domain -> IO CoDomain

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

printAns :: CoDomain -> IO ()
printAns = putStrLn . show

parse :: IO Domain
parse = do
  xs <- map (=='1') <$> getLine
  return xs

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

type Count = IOUArray (Int, Int, Int) Int

ones :: Int -> Int
ones 0 = 0
ones 1 = 1
ones i
  | even i = ni
  | odd i = ni + 1
  where ni = ones $ i `div` 2

solve1 :: [Bool] -> IO Count
solve1 xs = do
    c <- newArray ((0, 0, 0), (length xs, 7, 7)) 0
    writeArray c (0,0,0) 1
    mapM_ (go c) $ indices xs
    return c
    where
      indices :: [Bool] -> [(Int, Bool, Int, Int, Int)]
      indices xs = [(k, x ,mask, i, j)
        | (k, x) <- zip [0..length xs-1] xs
        , mask <-[0..7]
        , i <- [0..7]
        , j <- [0..7]
        , x || (mask .&. i) == mask
         ]
      go ::
        Count
        -> (
          Int -- index for xs
        , Bool
        , Int -- mask
        ,  Int -- prefix less
        ,  Int) -- minor
        -> IO ()
      go c (k, isOne, mask, i, j) =
          do
            v1 <- readArray c (k, i, j)
            v2 <- readArray c (k+1, ni,nj)
            writeArray c (k+1,ni,nj) (v1+v2 `mod` mm)
          where
            vmask = 7 .&. (complement mask)
            ni = if isOne then i .|. vmask else i
            nj = case ones mask of
              1 -> j .|. mask
              2 -> j .|. vmask
              otherwise -> j

a :: Integer
a = 2
main :: IO ()
main = do
  -- print (range ((0,0),(7,7)) )
  -- print $ 2 ^ 200000
  xs <- parse
  res <- solve1 xs
  printAns =<< (foldr (((`mod` mm).) . (+)) 0) <$> sequence (readArray res <$> [(length xs, i, 7) |i <- [0..7]])
  return ()

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems, MArray)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.IntMap as IntMap
import Control.Monad.Trans.Class
import Data.Bits
import Data.Ix (Ix(range))

mm = 998244353
type Domain = [Bool]
type CoDomain = Int
type Solver  = Domain -> IO CoDomain

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

printAns :: CoDomain -> IO ()
printAns = putStrLn . show

parse :: IO Domain
parse = do
  xs <- map (=='1') <$> getLine
  return xs

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

type Count = IOUArray (Int, Int, Int) Int

ones :: Int -> Int
ones 0 = 0
ones 1 = 1
ones i
  | even i = ni
  | odd i = ni + 1
  where ni = ones $ i `div` 2

solve1 :: [Bool] -> IO Count
solve1 xs = do
    c <- newArray ((0, 0, 0), (length xs, 7, 7)) 0
    writeArray c (0,0,0) 1
    mapM_ (go c) $ indices xs
    return c
    where
      indices :: [Bool] -> [(Int, Bool, Int, Int, Int)]
      indices xs = [(k, x ,mask, i, j)
        |
        (k, x) <- zip [0..length xs-1] xs
        , mask <-[0..7]
        , i <- [0..7]
        , x || (mask .&. i) == mask
        , j <- [0..7]
         ]
      go ::
        Count
        -> (
          Int -- index for xs
        , Bool
        , Int -- mask
        ,  Int -- prefix less
        ,  Int) -- minor
        -> IO ()
      go c (k, isOne, mask, i, j) =
          do
            v1 <- readArray c (k, i, j)
            v2 <- readArray c (k+1, ni,nj)
            -- print (k, i, j)
            writeArray c (k+1,ni,nj) (v1+v2 `mod` mm)
          where
            vmask = 7 .&. (complement mask)
            ni = if isOne then i .|. vmask else i
            nj = case ones mask of
              1 -> j .|. mask
              2 -> j .|. vmask
              otherwise -> j

a :: Integer
a = 2
main :: IO ()
main = do
  -- print (range ((0,0),(7,7)) )
  -- print $ 2 ^ 200000
  xs <- parse
  res <- solve1 xs
  printAns =<< (foldr (((`mod` mm).) . (+)) 0) <$> sequence (readArray res <$> [(length xs, i, 7) |i <- [0..7]])
  return ()

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems, MArray)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.IntMap as IntMap
import Control.Monad.Trans.Class
import Data.Bits
import Data.Ix (Ix(range))

mm = 998244353
type Domain = [Bool]
type CoDomain = Int
type Solver  = Domain -> IO CoDomain

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

printAns :: CoDomain -> IO ()
printAns = putStrLn . show

parse :: IO Domain
parse = do
  xs <- map (=='1') <$> getLine
  return xs

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

type Count = IOUArray (Int, Int, Int) Int

ones :: Int -> Int
ones 0 = 0
ones 1 = 1
ones i
  | even i = ni
  | odd i = ni + 1
  where ni = ones $ i `div` 2

solve1 :: [Bool] -> IO Count
solve1 xs = do
    c <- newArray ((0, 0, 0), (length xs, 7, 7)) 0
    writeArray c (0,0,0) 1
    mapM_ (go c) $ indices xs
    return c
    where
      indices :: [Bool] -> [(Int, Bool, Int, Int, Int)]
      indices xs = [(k, x ,mask, i, j)
        |
        (k, x) <- zip [0..length xs-1] xs
        , mask <-[0..7]
        , i <- [0..7]
        , x || (mask .&. i) == mask
        , j <- [0..7]
         ]
      go ::
        Count
        -> (
          Int -- index for xs
        , Bool
        , Int -- mask
        ,  Int -- prefix less
        ,  Int) -- minor
        -> IO ()
      go c (k, isOne, mask, i, j) =
          do
            v1 <- readArray c (k, i, j)
            v2 <- readArray c (k+1, ni,nj)
            print (k, i, j)
            writeArray c (k+1,ni,nj) (v1+v2 `mod` mm)
          where
            vmask = 7 .&. (complement mask)
            ni = if isOne then i .|. vmask else i
            nj = case ones mask of
              1 -> j .|. mask
              2 -> j .|. vmask
              otherwise -> j

a :: Integer
a = 2
main :: IO ()
main = do
  -- print (range ((0,0),(7,7)) )
  -- print $ 2 ^ 200000
  xs <- parse
  res <- solve1 xs
  printAns =<< (foldr (((`mod` mm).) . (+)) 0) <$> sequence (readArray res <$> [(length xs, i, 7) |i <- [0..7]])
  return ()

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems, MArray)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.IntMap as IntMap
import Control.Monad.Trans.Class
import Data.Bits
import Data.Ix (Ix(range))

mm = 998244353
type Domain = [Bool]
type CoDomain = Int
type Solver  = Domain -> IO CoDomain

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

printAns :: CoDomain -> IO ()
printAns = putStrLn . show

parse :: IO Domain
parse = do
  xs <- map (=='1') <$> getLine
  return xs

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

type Count = IOUArray (Int, Int, Int) Int

ones :: Int -> Int
ones 0 = 0
ones 1 = 1
ones i
  | even i = ni
  | odd i = ni + 1
  where ni = ones $ i `div` 2

solve1 :: [Bool] -> IO Count
solve1 xs = do
    c <- newArray ((0, 0, 0), (length xs, 7, 7)) 0
    writeArray c (0,0,0) 1
    mapM_ (go c) $ indices xs
    return c
    where
      indices :: [Bool] -> [(Int, Bool, Int, Int, Int)]
      indices xs = [(k, x ,mask, i, j)
        | mask <-[0..7]
        , i <- [0..7]
        , (k, x) <- zip [0..length xs-1] xs
        , x || (mask .&. i) == mask
        , j <- [0..7]
         ]
      go ::
        Count
        -> (
          Int -- index for xs
        , Bool
        , Int -- mask
        ,  Int -- prefix less
        ,  Int) -- minor
        -> IO ()
      go c (k, isOne, mask, i, j) =
          do
            v1 <- readArray c (k, i, j)
            v2 <- readArray c (k+1, ni,nj)
            writeArray c (k+1,ni,nj) (v1+v2 `mod` mm)
          where
            vmask = 7 .&. (complement mask)
            ni = if isOne then i .|. vmask else i
            nj = case ones mask of
              1 -> j .|. mask
              2 -> j .|. vmask
              otherwise -> j

a :: Integer
a = 2
main :: IO ()
main = do
  -- print (range ((0,0),(7,7)) )
  -- print $ 2 ^ 200000
  xs <- parse
  res <- solve1 xs
  printAns =<< (foldr (((`mod` mm).) . (+)) 0) <$> sequence (readArray res <$> [(length xs, i, 7) |i <- [0..7]])
  return ()

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems, MArray)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'), foldrM)
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.IntMap as IntMap
import Control.Monad.Trans.Class
import Data.Bits
import Data.Ix (Ix(range))

mm = 998244353
type Domain = [Bool]
type CoDomain = Int
type Solver  = Domain -> IO CoDomain

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

printAns :: CoDomain -> IO ()
printAns = putStrLn . show

parse :: IO Domain
parse = do
  xs <- map (=='1') <$> getLine
  return xs

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

type Count = IOUArray (Int, Int, Int) Int

ones :: Int -> Int
ones 0 = 0
ones 1 = 1
ones i
  | even i = ni
  | odd i = ni + 1
  where ni = ones $ i `div` 2

solve1 :: [Bool] -> IO Count
solve1 xs = do
    c <- newArray ((0, 0, 0), (length xs, 7, 7)) 0
    writeArray c (0,0,0) 1
    mapM_ (go c) $ indices xs
    return c
    where
      indices :: [Bool] -> [(Int, Bool, Int, Int, Int)]
      indices xs = [(k, x ,mask, i, j)
        | mask <-[0..7]
        , i <- [0..7]
        , (k, x) <- zip [0..length xs-1] xs
        , x || mask .&. i == mask
        , j <- [0..7]
         ]
      go ::
        Count
        -> (
          Int -- index for xs
        , Bool
        , Int -- mask
        ,  Int -- prefix less
        ,  Int) -- minor
        -> IO ()
      go c (k, isOne, mask, i, j) =
          do
            v1 <- readArray c (k, i, j)
            v2 <- readArray c (k+1, ni,nj)
            writeArray c (k+1,ni,nj) (v1+v2 `mod` mm)
          where
            vmask = 7 .&. (complement mask)
            ni = if isOne then i .|. vmask else i
            nj = case ones mask of
              1 -> j .|. mask
              2 -> j .|. vmask
              otherwise -> j

a :: Integer
a = 2
main :: IO ()
main = do
  -- print (range ((0,0),(7,7)) )
  -- print $ 2 ^ 200000
  xs <- parse
  res <- solve1 xs
  printAns =<< (foldr (((`mod` mm).) . (+)) 0) <$> sequence (readArray res <$> [(length xs, i, 7) |i <- [0..7]])
  return ()

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'))
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.IntMap as IntMap
import Control.Monad.Trans.Class
import Data.Bits

mm = 998244353
type Domain = [Bool]
type CoDomain = Int
type Solver  = Domain -> CoDomain

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

printAns :: CoDomain -> IO ()
printAns = putStrLn . show

parse :: IO Domain
parse = do
  xs <- map (=='1') <$> getLine
  return xs

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

type Count = Map.IntMap Int

ones :: Int -> Int
ones 0 = 0
ones 1 = 1
ones i
  | even i = ni
  | odd i = ni + 1
  where ni = ones $ i `div` 2

gi :: Int -> Int -> Int
gi i j = i * 8 + j

solve1 :: [Bool] -> Count
solve1 xs = foldl
  (\m (k, a) ->  foldr (\(mask, g) m1 ->  go m m1 a k mask (g`div`8) (g`mod`8)) Map.empty $ liftM2 (,) [0..7] (Map.keys m))
  (Map.fromList [((0 `gi` 0),1)])
  (zip [0..] xs)
    where
      updateX :: Int -> Maybe Int -> Maybe Int
      updateX x Nothing = Just x
      updateX x (Just y) = Just (x+y)
      inject :: Count -> (Int, Int) -> Count
      inject c (k, v) = Map.alter (updateX v) k c

      go ::
        Count
        -> Count
        -> Bool
        -> Int -- count
        -> Int -- mask
        -> Int -- prefix less
        -> Int -- minor
        -> Count
      go c c2 isOne k mask i j
        | isOne || (mask .&. i) == mask = inject c2 ((ni`gi`nj), c Map.! (i `gi` j))
        | otherwise = inject c2 ((0`gi`0),0)
          where
            vmask = 7 .&. (complement mask)
            ni = if isOne then i .|. vmask else i
            nj = case ones mask of
              1 -> j .|. mask
              2 -> j .|. vmask
              otherwise -> j

solve :: Solver
solve xs = (`mod` mm) $ sum $ Map.elems $ Map.filterWithKey (\k _ -> k`mod`8==7) $ solve1 xs

main :: IO ()
main = do
  printAns =<< solve <$> parse
  return ()

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'))
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.IntMap as IntMap
import Control.Monad.Trans.Class
import Data.Bits

mm = 998244353
type Domain = [Bool]
type CoDomain = Int
type Solver  = Domain -> CoDomain

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

printAns :: CoDomain -> IO ()
printAns = putStrLn . show

parse :: IO Domain
parse = do
  xs <- map (=='1') <$> getLine
  return xs

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

type Count = Map.IntMap Int

ones :: Int -> Int
ones 0 = 0
ones 1 = 1
ones i
  | even i = ni
  | odd i = ni + 1
  where ni = ones $ i `div` 2

gi :: Int -> Int -> Int
gi i j = i * 8 + j

solve1 :: [Bool] -> Count
solve1 xs = foldl
  (\m ys -> Map.fromListWith (((`mod` mm).) . (+)) $ (\(isOne, k, mask,i,j) -> go m isOne k mask i j) <$> ys (Map.keys m))
  (Map.fromList [((0 `gi` 0),1)])
  indices
    where
      indices =
        [\keys -> [(xs!!k, k, mask, g `div` 8, g `mod` 8) | mask <-[0..7],g <- keys ] | k <- [0..length xs-1]]
      go :: Count
        -> Bool
        -> Int -- count
        -> Int -- mask
        -> Int -- prefix less
        -> Int -- minor
        -> (Int, Int)
      go c isOne k mask i j
        | isOne || (mask .&. i) == mask = ((ni`gi`nj), c Map.! (i `gi` j))
        | otherwise = ((0`gi`0),0)
          where
            vmask = 7 .&. (complement mask)
            ni = if isOne then i .|. vmask else i
            nj = case ones mask of
              1 -> j .|. mask
              2 -> j .|. vmask
              otherwise -> j

solve :: Solver
solve xs = (`mod` mm) $ sum $ Map.elems $ Map.filterWithKey (\k _ -> k`mod`10==7) $ solve1 xs

main :: IO ()
main = do
  printAns =<< solve <$> parse
  return ()

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM, foldM, when)
import Data.Char (digitToInt, toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map.Strict (Map, insert, alter, empty, (!), (!?), fromList, fromListWith, mapWithKey, findWithDefault, unionWithKey, traverseWithKey, mapKeys, filterWithKey, mapKeysWith)
import Data.List (group, sort)
import Data.Set (Set, deleteFindMin, union)
import qualified Data.Set as Set
import qualified Data.IntMap as Map
import Data.Function (on)
import Data.Array.MArray (newArray, readArray, writeArray, newListArray)
import Data.Array.IO (IOUArray, getElems, MArray)
import Data.Bool (bool)
import Data.Foldable (foldlM, Foldable (foldl'))
import Control.Arrow ((&&&), Arrow ((***)))
import Data.Coerce (coerce)
import Data.Set.Internal(Set(Bin, Tip))
import Debug.Trace (traceShowId, traceShow)
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.IntMap as IntMap
import Control.Monad.Trans.Class
import Data.Bits

mm = 998244353
type Domain = [Bool]
type CoDomain = Int
type Solver  = Domain -> IO CoDomain

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

printAns :: CoDomain -> IO ()
printAns = putStrLn . show

parse :: IO Domain
parse = do
  xs <- map (=='1') <$> getLine
  return xs

showResult :: [Bool] -> String
showResult xs = (bool '0' '1') <$> xs

type Count = IOUArray Int Int

ones :: Int -> Int
ones 0 = 0
ones 1 = 1
ones i
  | even i = ni
  | odd i = ni + 1
  where ni = ones $ i `div` 2

gi :: Int -> Int -> Int
gi i j = i * 10 + j

solve1 :: [Bool] -> IO Count
solve1 xs = do
    c1 <- newArray (0, 7`gi`7) 0
    writeArray c1 0 1
    foldlM goBig c1 indices
    where
      goBig :: Count -> [(Bool, Int, Int, Int, Int)] -> IO Count
      goBig c1 xs = do
        c2 <- newArray (0, 7`gi`7) 0
        mapM_ (\(isOne, k, mask,i,j) -> go c1 c2 isOne k mask i j) xs
        return c2

      indices = [[(xs!!k, k, mask, i, j) | mask <-[0..7],i <- [0..7], j <- [0..7]] | k <- [0..length xs-1]]
      go ::
        Count
        -> Count
        -> Bool
        -> Int -- count
        -> Int -- mask
        -> Int -- prefix less
        -> Int -- minor
        -> IO ()
      go c1 c2 isOne k mask i j
        | isOne || (mask .&. i) == mask =
          do
            val1 <- readArray c1 (i `gi` j)
            val2 <- readArray c2 (ni`gi`nj)
            writeArray c2 (ni`gi`nj) (val1+val2)
        | otherwise = return ()
          where
            vmask = 7 .&. (complement mask)
            ni = if isOne then i .|. vmask else i
            nj = case ones mask of
              1 -> j .|. mask
              2 -> j .|. vmask
              otherwise -> j

solve2 :: IOUArray Int Int -> Int
solve2 xs = undefined
go :: [Bool] -> IO ()
go bs = do
  na <- newArray (0, length bs -1 ) 0
  let x = solve2 na
  return ()

a :: Int
a = 1 .&. 1

main :: IO ()
main = do
  res <- solve1 =<< parse
  printAns =<< (\x -> mod (sum x) mm) <$> sequence (readArray res <$> [i `gi` 7 |i <- [0..7]])
  -- printAns =<<
  return ()


Nezzar has $$$n$$$ balls, numbered with integers $$$1, 2, \ldots, n$$$. Numbers $$$a_1, a_2, \ldots, a_n$$$ are written on them, respectively. Numbers on those balls form a non-decreasing sequence, which means that $$$a_i \leq a_{i+1}$$$ for all $$$1 \leq i < n$$$.Nezzar wants to color the balls using the minimum number of colors, such that the following holds.  For any color, numbers on balls will form a strictly increasing sequence if he keeps balls with this chosen color and discards all other balls.  Note that a sequence with the length at most $$$1$$$ is considered as a strictly increasing sequence.Please help Nezzar determine the minimum number of colors.

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 100$$$) — the number of testcases.  The first line of each test case contains a single integer $$$n$$$ ($$$1 \le n \le 100$$$). The second line of each test case contains $$$n$$$ integers $$$a_1,a_2,\ldots,a_n$$$ ($$$1 \le a_i \le n$$$). It is guaranteed that $$$a_1 \leq a_2 \leq \ldots \leq a_n$$$.

For each test case, output the minimum number of colors Nezzar can use.

NoteLet's match each color with some numbers. Then:In the first test case, one optimal color assignment is $$$[1,2,3,3,2,1]$$$.In the second test case, one optimal color assignment is $$$[1,2,1,2,1]$$$.

toArray :: String -> [Int]
toArray = map (read :: String -> Int) . words

process :: [Int] -> Int
process = maximum . compress
    where  compress [] = []
           compress (x : xs) =
               let (pref, suf) = span (==x) xs
               in 1 + length pref : compress suf

main :: IO ()
main = interact (unlines . map (show . process . toArray) . takeEven . tail . lines)
    where takeEven l = map snd $ filter (even . fst) (zip [1..] l)

toArray :: String -> [Int]
toArray = map (read :: String -> Int) . words

process :: [Int] -> Int
process = maximum . compressed
    where compressed [] = []
          compressed (x : xs) = 1 + length (takeWhile (==x) xs) :
                                    compressed (dropWhile (==x) xs)

main :: IO ()
main = interact (unlines . map (show . process . toArray) . takeEven . tail . lines)
    where takeEven l = map snd $ filter (even . fst) (zip [1..] l)


You are responsible for installing a gas pipeline along a road. Let's consider the road (for simplicity) as a segment $$$[0, n]$$$ on $$$OX$$$ axis. The road can have several crossroads, but for simplicity, we'll denote each crossroad as an interval $$$(x, x + 1)$$$ with integer $$$x$$$. So we can represent the road as a binary string consisting of $$$n$$$ characters, where character 0 means that current interval doesn't contain a crossroad, and 1 means that there is a crossroad.Usually, we can install the pipeline along the road on height of $$$1$$$ unit with supporting pillars in each integer point (so, if we are responsible for $$$[0, n]$$$ road, we must install $$$n + 1$$$ pillars). But on crossroads we should lift the pipeline up to the height $$$2$$$, so the pipeline won't obstruct the way for cars.We can do so inserting several zig-zag-like lines. Each zig-zag can be represented as a segment $$$[x, x + 1]$$$ with integer $$$x$$$ consisting of three parts: $$$0.5$$$ units of horizontal pipe + $$$1$$$ unit of vertical pipe + $$$0.5$$$ of horizontal. Note that if pipeline is currently on height $$$2$$$, the pillars that support it should also have length equal to $$$2$$$ units.  Each unit of gas pipeline costs us $$$a$$$ bourles, and each unit of pillar — $$$b$$$ bourles. So, it's not always optimal to make the whole pipeline on the height $$$2$$$. Find the shape of the pipeline with minimum possible cost and calculate that cost.Note that you must start and finish the pipeline on height $$$1$$$ and, also, it's guaranteed that the first and last characters of the input string are equal to 0.

The fist line contains one integer $$$T$$$ ($$$1 \le T \le 100$$$) — the number of queries. Next $$$2 \cdot T$$$ lines contain independent queries — one query per two lines. The first line contains three integers $$$n$$$, $$$a$$$, $$$b$$$ ($$$2 \le n \le 2 \cdot 10^5$$$, $$$1 \le a \le 10^8$$$, $$$1 \le b \le 10^8$$$) — the length of the road, the cost of one unit of the pipeline and the cost of one unit of the pillar, respectively. The second line contains binary string $$$s$$$ ($$$|s| = n$$$, $$$s_i \in \{0, 1\}$$$, $$$s_1 = s_n = 0$$$) — the description of the road. It's guaranteed that the total length of all strings $$$s$$$ doesn't exceed $$$2 \cdot 10^5$$$.

Print $$$T$$$ integers — one per query. For each query print the minimum possible cost of the constructed pipeline.

NoteThe optimal pipeline for the first query is shown at the picture above.The optimal pipeline for the second query is pictured below:  The optimal (and the only possible) pipeline for the third query is shown below:  The optimal pipeline for the fourth query is shown below:

import Data.Int
import Data.List
import Control.Monad

traceShowId = id

main = do
  t <- readLn
  replicateM_ t $ do
    [n,a,b] <- map read . words <$> getLine :: IO [Int64]
    road <- getLine
    print $ solve a b $ group road
solve a b [road] = traceShowId $ a * genericLength road + b * (genericLength road + 1)
solve a b (start:road) = go road $! traceShowId (a * (genericLength (traceShowId start) + 1) + b * (genericLength start + 2))
 where
  go [end] acc = acc + traceShowId (a * (genericLength (traceShowId end) + 1) + b * (genericLength end + 2))
  go (seg@(h:_):road) acc = go road $! acc + (traceShowId $
    case h of '1' -> a * genericLength (traceShowId seg) + 2*b * (genericLength seg - 1)
              '0' -> min (a * (genericLength (traceShowId seg) + 2) + b * (genericLength seg + 3))
                         (a * genericLength seg + 2*b * (genericLength seg + 1))

    )

gint :: IO Int
gint = fmap read getLine
main = do
    t <- gint
    mymain t

mymain 0 = return ()
mymain x = do
    strabc <- getLine
    strbits <- getLine
    let [a,b,c] = map read $ words strabc
    print (fst (solve b c strbits))
    mymain (x - 1)

solve :: Integer -> Integer -> String -> (Integer,Integer)
solve pipeline pillar [] = (pillar, 1000000000000000000)
solve pipeline pillar (b:road)
    | b == '0' = (newdown, newup)
    | b == '1' = (1000000000000000000,  newup1)
    where (down, up) = solve pipeline pillar road
          newup = 2 * pillar + (min (up + pipeline) (down + 2*pipeline) )
          newdown = pillar + (min (up + 2 * pipeline) (down + pipeline) )
          newup1 = 2 * pillar + up + pipeline

import Data.List
import Control.Monad

traceShowId = id

main = do
  t <- readLn
  replicateM_ t $ do
    [n,a,b] <- map read . words <$> getLine
    road <- getLine
    print $ solve a b $ group road
solve a b [road] = traceShowId $ a * length road + b * (length road + 1)
solve a b (start:road) = go road $! traceShowId (a * (length (traceShowId start) + 1) + b * (length start + 2))
 where
  go [end] acc = acc + traceShowId (a * (length (traceShowId end) + 1) + b * (length end + 2))
  go (seg@(h:_):road) acc = go road $! acc + (traceShowId $
    case h of '1' -> a * length (traceShowId seg) + 2*b * (length seg - 1)
              '0' -> min (a * (length (traceShowId seg) + 2) + b * (length seg + 3))
                         (a * length seg + 2*b * (length seg + 1))

    )


A class of students got bored wearing the same pair of shoes every day, so they decided to shuffle their shoes among themselves. In this problem, a pair of shoes is inseparable and is considered as a single object.There are $$$n$$$ students in the class, and you are given an array $$$s$$$ in non-decreasing order, where $$$s_i$$$ is the shoe size of the $$$i$$$-th student. A shuffling of shoes is valid only if no student gets their own shoes and if every student gets shoes of size greater than or equal to their size. You have to output a permutation $$$p$$$ of $$$\{1,2,\ldots,n\}$$$ denoting a valid shuffling of shoes, where the $$$i$$$-th student gets the shoes of the $$$p_i$$$-th student ($$$p_i \ne i$$$). And output $$$-1$$$ if a valid shuffling does not exist.A permutation is an array consisting of $$$n$$$ distinct integers from $$$1$$$ to $$$n$$$ in arbitrary order. For example, $$$[2,3,1,5,4]$$$ is a permutation, but $$$[1,2,2]$$$ is not a permutation ($$$2$$$ appears twice in the array) and $$$[1,3,4]$$$ is also not a permutation ($$$n=3$$$ but there is $$$4$$$ in the array).

Each test contains multiple test cases. The first line contains a single integer $$$t$$$ ($$$1 \le t \le 1000$$$) — the number of test cases. Description of the test cases follows. The first line of each test case contains a single integer $$$n$$$ ($$$1\leq n\leq10^5$$$) — the number of students. The second line of each test case contains $$$n$$$ integers $$$s_1, s_2,\ldots,s_n$$$ ($$$1\leq s_i\leq10^9$$$, and for all $$$1\le i<n$$$, $$$s_i\le s_{i+1}$$$) — the shoe sizes of the students. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$10^5$$$.

For each test case, print the answer in a single line using the following format. If a valid shuffling does not exist, print the number $$$-1$$$ as the answer. If a valid shuffling exists, print $$$n$$$ space-separated integers — a permutation $$$p$$$ of $$$1,2,\ldots,n$$$ denoting a valid shuffling of shoes where the $$$i$$$-th student gets the shoes of the $$$p_i$$$-th student. If there are multiple answers, then print any of them.

NoteIn the first test case, any permutation $$$p$$$ of $$$1,\ldots,n$$$ where $$$p_i\ne i$$$ would represent a valid shuffling since all students have equal shoe sizes, and thus anyone can wear anyone's shoes.In the second test case, it can be shown that no valid shuffling is possible.

{-# LANGUAGE NegativeLiterals,  InstanceSigs, MultiParamTypeClasses, UndecidableSuperClasses, MultiWayIf, KindSignatures,
OverloadedLists,ApplicativeDo,OverloadedStrings,MonadComprehensions,ParallelListComp,TransformListComp, TupleSections,
BlockArguments, TypeApplications, PostfixOperators, TypeOperators, BangPatterns, LambdaCase, UnboxedSums, UnboxedTuples, RankNTypes,
FlexibleContexts,DeriveFoldable, DeriveTraversable, ScopedTypeVariables, GADTs, PatternSynonyms, ViewPatterns, FunctionalDependencies #-}
import Data.List (group, sort, groupBy)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Function ((&),fix,on)

failCheck :: [L.ByteString] -> Bool
failCheck    = any (==1) . map length . group
success :: [L.ByteString] -> L.ByteString
success = L.unwords . map (L.pack . show) . concatMap (\(x:xs) -> xs ++ [x]) . (map.map)fst . groupBy ((==)  `on` snd) . zip [1..]

procLine :: [L.ByteString] -> L.ByteString
procLine xs
 | failCheck xs = "-1"
 | otherwise    = success xs

twos :: [L.ByteString] ->   [L.ByteString]
twos [] = []
twos (_:y:xs) = y : twos xs

main :: IO ()
main = L.interact (L.unlines . map procLine . map L.words . twos . tail . L.lines)


Mahmoud wrote a message s of length n. He wants to send it as a birthday present to his friend Moaz who likes strings. He wrote it on a magical paper but he was surprised because some characters disappeared while writing the string. That's because this magical paper doesn't allow character number i in the English alphabet to be written on it in a string of length more than ai. For example, if a1 = 2 he can't write character 'a' on this paper in a string of length 3 or more. String "aa" is allowed while string "aaa" is not.Mahmoud decided to split the message into some non-empty substrings so that he can write every substring on an independent magical paper and fulfill the condition. The sum of their lengths should be n and they shouldn't overlap. For example, if a1 = 2 and he wants to send string "aaa", he can split it into "a" and "aa" and use 2 magical papers, or into "a", "a" and "a" and use 3 magical papers. He can't split it into "aa" and "aa" because the sum of their lengths is greater than n. He can split the message into single string if it fulfills the conditions.A substring of string s is a string that consists of some consecutive characters from string s, strings "ab", "abc" and "b" are substrings of string "abc", while strings "acb" and "ac" are not. Any string is a substring of itself.While Mahmoud was thinking of how to split the message, Ehab told him that there are many ways to split it. After that Mahmoud asked you three questions:   How many ways are there to split the string into substrings such that every substring fulfills the condition of the magical paper, the sum of their lengths is n and they don't overlap? Compute the answer modulo 109 + 7.  What is the maximum length of a substring that can appear in some valid splitting?  What is the minimum number of substrings the message can be spit in? Two ways are considered different, if the sets of split positions differ. For example, splitting "aa|a" and "a|aa" are considered different splittings of message "aaa".

The first line contains an integer n (1 ≤ n ≤ 103) denoting the length of the message. The second line contains the message s of length n that consists of lowercase English letters. The third line contains 26 integers a1, a2, ..., a26 (1 ≤ ax ≤ 103) — the maximum lengths of substring each letter can appear in.

Print three lines. In the first line print the number of ways to split the message into substrings and fulfill the conditions mentioned in the problem modulo 109  +  7. In the second line print the length of the longest substring over all the ways. In the third line print the minimum number of substrings over all the ways.

NoteIn the first example the three ways to split the message are:   a|a|b  aa|b  a|ab The longest substrings are "aa" and "ab" of length 2.The minimum number of substrings is 2 in "a|ab" or "aa|b".Notice that "aab" is not a possible splitting because the letter 'a' appears in a substring of length 3, while a1 = 2.

{-# LANGUAGE BangPatterns #-}
module Main where
import qualified Data.ByteString.Char8 as B
import Data.Array.Unboxed

readInt = maybe undefined fst . B.readInt
readInts = fmap readInt . B.words

solve n s as0 = [cnt!n, maximum $ zipWith (-) [1..] bs, mc!n]
  where
    as = listArray ('a', 'z') as0 :: UArray Char Int
    bs = map (\(i, c2l) -> foldl (\(!b) (c, l) -> let b' = i - as!c in max b $ min l b') 0 $ assocs c2l) $ zip [1..] $ tail $ scanl (\a p -> a // [p]) (listArray ('a', 'z') (repeat (-9000)) :: UArray Char Int) $ zip s [1..]
    cnt = listArray (-1, n) $ ([0, 1] ++) $ map (\(i, b) -> (ps!(i - 1)) -% (ps!(b - 1))) $ zip [1..] bs :: Array Int Int
    ps = listArray (-1, n) $ scanl1 (+%) $ elems cnt :: Array Int Int
    mc = listArray (0, n) $ (0:) $ map ((+1) . (mc!)) bs :: Array Int Int
    mb = 1000000007
    a +% b = (a + b) `rem` mb
    a -% b = (a - b) `mod` mb

main = do
  n <- fmap readInt B.getLine
  s <- getLine
  as <- fmap readInts B.getLine
  putStr $ unlines $ map show $ solve n s as

import qualified Data.Array as A
import Data.Char (ord)

main = interact $ printAns. uncurry solve. readInp

readInp = prep. tail. lines
    where prep (s:lst:_) = (s, A.listArray (0, 25). fmap read. words $ lst)

printAns (a,b,c) = unlines. map show $ [a,b,c]

solve :: String -> A.Array Int Int -> (Int,Int,Int)
solve s a = d slen
  where slen = length s
        lims = A.listArray (1, slen) (map toLim s)
        toLim = (a A.!). (\x -> x - (ord 'a')). ord

        d 0 = (1,0,0)
        d i = getRes. toVals. okPos $ (reverse [0..i-1])
            where okPos l = map snd. takeWhile isOk. zip (lstLim l) $ l
                  lstLim = scanl1 min. map ((lims A.!). (+1))
                  isOk (a, b) = a >= dist i b
                  dist = (-)
                  toVals = map (ds A.!)
                  getRes l = addCur (length l). foldl upd (0,0,10^5) $ l
                  upd (a,b,c) (x,y,z) = (add a x, max b y, min c z)
                  addCur len (a,b,c) = (a, max b len, c+1)

        ds = A.listArray bounds
               [d i | i <- A.range bounds]
        bounds = (0, slen)

        add a b = (a+b) `rem` md
        md = 10^9 + 7

import qualified Data.Array as A
import Data.Char (ord)

main = interact $ printAns. uncurry solve. readInp

readInp = prep. tail. lines
    where prep (s:lst:_) = (s, A.listArray (0, 25). fmap read. words $ lst)

printAns (a,b,c) = unlines. map show $ [a,b,c]

solve :: String -> A.Array Int Int -> (Int,Int,Int)
solve s a = d slen
  where slen = length s
        lims = A.listArray (1, slen) (map toLim s)
        toLim = (a A.!). (flip (-) (ord 'a')). ord

        d 0 = (1,0,0)
        d i = getRes. toVals. okPos $ (reverse [0..i-1])
            where okPos l = map snd. takeWhile isOk. zip (lstLim l) $ l
                  lstLim = scanl1 min. map ((lims A.!). (+1))
                  isOk (a, b) = a >= dist i b
                  dist = (-)
                  toVals = map (ds A.!)
                  getRes l = addCur (length l). foldl upd (0,0,10^5) $ l
                  upd (a,b,c) (x,y,z) = (add a x, max b y, min c z)
                  addCur len (a,b,c) = (a, max b len, c+1)

        ds = A.listArray bounds
               [d i | i <- A.range bounds]
        bounds = (0, slen)

        add a b = (a+b) `rem` md
        md = 10^9 + 7

import qualified Data.Array as A
import Data.Char (ord)

main = interact $ printAns. uncurry solve. readInp

readInp = prep. tail. lines
    where prep (s:lst:_) = (s, A.listArray (0, 25). fmap read. words $ lst)

printAns (a,b,c) = unlines. map show $ [a,b,c]

solve :: String -> A.Array Int Int -> (Int,Int,Int)
solve s a = d slen
  where slen = length s
        lims = A.listArray (1, slen) (map toLim s)
        toLim = (a A.!). (\x -> x - (ord 'a')). ord

        d 0 = (1,0,0)
        d i = getRes. toVals. okPos $ (reverse [0..i-1])
            where okPos l = map snd. takeWhile isOk. zip (lstLim l) $ l
                  lstLim = scanl1 min. map ((lims A.!). (+1))
                  isOk (a, b) = a >= i - b
                  toVals = map (ds A.!)
                  getRes l = addCur (length l). foldl upd (0,0,10^5) $ l
                  upd (a,b,c) (x,y,z) = (add a x, max b y, min c z)
                  addCur len (a,b,c) = (a, max b len, c+1)

        ds = A.listArray bounds
               [d i | i <- A.range bounds]
        bounds = (0, slen)

        add a b = (a+b) `rem` md
        md = 10^9 + 7

import qualified Data.Array as A
import Data.Char (ord)

main = interact $ printAns. uncurry solve. readInp

readInp = prep. tail. lines
    where prep (s:lst:_) = (s, A.listArray (0, 25). fmap read. words $ lst)

printAns (a,b,c) = unlines. map show $ [a,b,c]

solve :: String -> A.Array Int Int -> (Int,Int,Int)
solve s a = d slen
  where slen = length s
        lims = A.listArray (1, slen) (map toLim s)
        toLim = (a A.!). (flip (-) (ord 'a')). ord

        d 0 = (1,0,0)
        d i = getRes. toVals. okPos $ (reverse [0..i-1])
            where okPos l = map snd. takeWhile isOk. zip (lstLim l) $ l
                  lstLim = scanl1 min. map ((lims A.!). (+1))
                  isOk (a, b) = a >= dist i b
                  dist = (-)
                  toVals = map (ds A.!)
                  getRes l = addCur (length l). foldl upd (0,0,10^5) $ l
                  upd (a,b,c) (x,y,z) = (a + x, max b y, min c z)
                  addCur len (a,b,c) = (a, max b len, c+1)

        ds = A.listArray bounds
               [d i | i <- A.range bounds]
        bounds = (0, slen)

        add a b = (a+b) `rem` md
        md = 10^9 + 7


You are an adventurer currently journeying inside an evil temple. After defeating a couple of weak zombies, you arrived at a square room consisting of tiles forming an n × n grid. The rows are numbered 1 through n from top to bottom, and the columns are numbered 1 through n from left to right. At the far side of the room lies a door locked with evil magical forces. The following inscriptions are written on the door: The cleaning of all evil will awaken the door! Being a very senior adventurer, you immediately realize what this means. You notice that every single cell in the grid are initially evil. You should purify all of these cells.The only method of tile purification known to you is by casting the "Purification" spell. You cast this spell on a single tile — then, all cells that are located in the same row and all cells that are located in the same column as the selected tile become purified (including the selected tile)! It is allowed to purify a cell more than once.You would like to purify all n × n cells while minimizing the number of times you cast the "Purification" spell. This sounds very easy, but you just noticed that some tiles are particularly more evil than the other tiles. You cannot cast the "Purification" spell on those particularly more evil tiles, not even after they have been purified. They can still be purified if a cell sharing the same row or the same column gets selected by the "Purification" spell.Please find some way to purify all the cells with the minimum number of spells cast. Print -1 if there is no such way.

The first line will contain a single integer n (1 ≤ n ≤ 100). Then, n lines follows, each contains n characters. The j-th character in the i-th row represents the cell located at row i and column j. It will be the character 'E' if it is a particularly more evil cell, and '.' otherwise.

If there exists no way to purify all the cells, output -1. Otherwise, if your solution casts x "Purification" spells (where x is the minimum possible number of spells), output x lines. Each line should consist of two integers denoting the row and column numbers of the cell on which you should cast the "Purification" spell.

NoteThe first example is illustrated as follows. Purple tiles are evil tiles that have not yet been purified. Red tile is the tile on which "Purification" is cast. Yellow tiles are the tiles being purified as a result of the current "Purification" spell. Green tiles are tiles that have been purified previously.   In the second example, it is impossible to purify the cell located at row 1 and column 1.For the third example:

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

import Control.Applicative
import Data.List

main :: IO ()
main = do
  n <- readLn :: IO Int
  css <- lines <$> getContents
  putStr.unlines.map(unwords.map show) $ solve css

solve :: [String] -> [[Int]]
solve css
  | all (any('.'==)) css = zipWith (:) [1..] [[i+1]|cs<-css,let Just i=findIndex ('.'==) cs]
  | all (any('.'==)) $ transpose css = map(\[i,j]->[j,i]).solve $ transpose css
  | otherwise = [[-1]]

import Control.Monad
import Control.Applicative
import Control.Arrow

import Data.List

main = do
    n <- read <$> getLine
    l <- replicateM n getLine
    case solve n l of
        [] -> putStrLn "-1"
        ls -> forM_ ls $ \ (r,c) -> putStrLn $ show r ++ " " ++ show c

solve :: Int -> [String] -> [(Int,Int)]
solve n l | length r1 == n = r1
          | length r2 == n = map swap r2
          | otherwise      = []
    where
    lt = transpose l
    r1 = zip l [1..] >>= f
    r2 = zip lt [1..] >>= f
    swap (a,b) = (b,a)

f (s,r) = case findIndex (=='.') s of
    Just c -> return (r,c+1)
    Nothing -> fail "impossible"

import Data.List (transpose)

solve :: [String] -> Maybe [(Int, Int)]
solve ss
  | findELine ss && findELine (transpose ss)  =  Nothing
  | not $ findELine ss  =  Just $ solve' ss
  | otherwise  =  Just $ map swap $ solve' $ transpose ss
  where
    findELine ss  =  any (all (== 'E')) ss
    swap (a, b)  =  (b, a)
    solve' ss  =  [(i, findDot s) | (i, s) <- zip [1..] ss]
    findDot  =  fst . head . filter ((== '.') . snd) . zip [1..]

print' :: Maybe [(Int, Int)] -> IO ()
print' Nothing  =  print (-1)
print' (Just xs)
    =  mapM_ (\(x, y) -> putStrLn (concat [show x, " ", show y])) xs

main :: IO ()
main  =  do
    n  <-  readLn
    ss  <-  sequence $ replicate n getLine
    print' $ solve ss

import Data.List (transpose)

solve :: [String] -> Maybe [(Int, Int)]
solve ss
  | findELine ss && findELine (transpose ss)  =  Nothing
  | not $ findELine ss  =  Just $ solve' ss
  | otherwise  =  Just $ map swap $ solve' $ transpose ss
  where
    findELine ss  =  any (all (== 'E')) ss
    swap (a, b)  =  (b, a)
    solve' ss  =  [(i, findDot s) | (i, s) <- zip [1..] ss]
    findDot  =  fst . head . filter ((== '.') . snd) . zip [1..]

print' :: Maybe [(Int, Int)] -> IO ()
print' Nothing  =  print (-1)
print' (Just xs)
    =  print (length xs) >> mapM_ (\(x, y) -> putStrLn (concat [show x, " ", show y])) xs

main :: IO ()
main  =  do
    n  <-  readLn
    ss  <-  sequence $ replicate n getLine
    print' $ solve ss


Three sons inherited from their father a rectangular corn fiend divided into n × m squares. For each square we know how many tons of corn grows on it. The father, an old farmer did not love all three sons equally, which is why he bequeathed to divide his field into three parts containing A, B and C tons of corn.The field should be divided by two parallel lines. The lines should be parallel to one side of the field and to each other. The lines should go strictly between the squares of the field. Each resulting part of the field should consist of at least one square. Your task is to find the number of ways to divide the field as is described above, that is, to mark two lines, dividing the field in three parts so that on one of the resulting parts grew A tons of corn, B on another one and C on the remaining one.

The first line contains space-separated integers n and m — the sizes of the original (1 ≤ n, m ≤ 50, max(n, m) ≥ 3). Then the field's description follows: n lines, each containing m space-separated integers cij, (0 ≤ cij ≤ 100) — the number of tons of corn each square contains. The last line contains space-separated integers A, B, C (0 ≤ A, B, C ≤ 106).

Print the answer to the problem: the number of ways to divide the father's field so that one of the resulting parts contained A tons of corn, another one contained B tons, and the remaining one contained C tons. If no such way exists, print 0.

NoteThe lines dividing the field can be horizontal or vertical, but they should be parallel to each other.

import Data.List

main = do
	input <- fmap lines $ readFile "input.txt"
	let [n, m] = map read . words . head $ input
	let v = map (map read . words) . take n . tail $ input
	let d = sort . map read . words $ input !! (n+1) :: [Int]
	let sumc = map sum v
	let sumr = [ sum $ map (!!i) v | i <- [0..m-1] ]
	let divc i j = sort . map sum $ [take i sumc, take (j-i) . drop i $ sumc, drop j sumc]
	let divr i j = sort . map sum $ [take i sumr, take (j-i) . drop i $ sumr, drop j sumr]
	writeFile "output.txt" . show . length $ [ 1 | i <- [1..n-1], j <- [i+1..n-1], d == divc i j ] ++ [ 1 | i <- [1..m-1], j <- [i+1..m-1], d == divr i j]

import IO
import List (sort)
import Array (Array (..), array, bounds, (!))

--------------------------------------------------------------------------------
{-
import HUnit

testInput  =  TestList "TestInput"
  [
    Test "1" $ assertEq 2 (solve (3,3,3) $ array ((1,1), (3,3)) [((i,j), 1) | i <- [1..3], j <- [1..3]]),
    Test "2" $ assertEq 3 (solve (3,6,6) $ array ((1,1), (2,5)) [((i,j), if i == 1 then 1 else 2) | i <- [1..2], j <- [1..5]])
  ]

test  =  mapM_ run
  [
    testInput
  ]
-}
--------------------------------------------------------------------------------

solve :: (Int, Int, Int) -> Array (Int, Int) Int -> Int
solve (a,b,c) d
  =  solve' (map sum (map (\i -> [d ! (i,j) | j <- [1..m]]) [1..n]))
  +  solve' (map sum (map (\j -> [d ! (i,j) | i <- [1..n]]) [1..m]))
  where
    (n, m)  =  snd $ bounds d
    abc  =  sort [a,b,c]
    solve' :: [Int] -> Int
    solve' xs  =  length [(i,j) | i <- [0..n-3], j <- [i+1..n-2],
        abc == sort [summ !! i, summ !! j - summ !! i, summ !! (n-1) - summ !! j]]
      where
        n  =  length xs
        summ  =  scanl1 (+) xs

parseLine :: Read a => String -> IO [a]
parseLine  =  return . map read . words

main :: IO ()
main  =  do
    hInput  <-  openFile "input.txt" ReadMode
    hOutput  <-  openFile "output.txt" WriteMode

    [n, m]  <-  hGetLine hInput >>= parseLine
    d  <-  mapM (\i -> hGetLine hInput >>= parseLine) [1..n]
    [a, b, c]  <-  hGetLine hInput >>= parseLine

    let res  =  solve (a,b,c) $ array ((1,1), (n,m)) [((i+1,j+1), d !! i !! j) | i <- [0..n-1], j <- [0..m-1]]

    hPrint hOutput res

    hClose hInput
    hClose hOutput

import Data.List

main = do
	input <- fmap lines $ readFile "input.txt"
	let [n, m] = map read . words . head $ input
	let v = map (map read . words) . take n . tail $ input
	let d = sort . map read . words $ input !! (n+1) :: [Int]
	let sumc = map sum v
	let sumr = [ sum $ map (!!i) v | i <- [0..m-1] ]
	let divc i j = sort . map sum $ [take i sumc, take (j-i) . drop i $ sumc, drop j sumc]
	let divr i j = sort . map sum $ [take i sumr, take (j-i) . drop i $ sumr, drop j sumr]
	writeFile "output.txt" . show . length $ [ 1 | i <- [0..n-1], j <- [i+1..n-1], d == divc i j ] ++ [ 1 | i <- [0..m-1], j <- [i+1..m-1], d == divr i j]

import IO
import List (sort)
import Array (Array (..), array, bounds, (!))

--------------------------------------------------------------------------------
{-
import HUnit

testInput  =  TestList "TestInput"
  [
    Test "1" $ assertEq 2 (solve (3,3,3) $ array ((1,1), (3,3)) [((i,j), 1) | i <- [1..3], j <- [1..3]]),
    Test "2" $ assertEq 3 (solve (3,6,6) $ array ((1,1), (2,5)) [((i,j), if i == 1 then 1 else 2) | i <- [1..2], j <- [1..5]])
  ]

test  =  mapM_ run
  [
    testInput
  ]
-}
--------------------------------------------------------------------------------

solve :: (Int, Int, Int) -> Array (Int, Int) Int -> Int
solve (a,b,c) d
  =  solve' (map sum (map (\i -> [d ! (i,j) | j <- [1..m]]) [1..n]))
  +  solve' (map sum (map (\j -> [d ! (i,j) | i <- [1..n]]) [1..m]))
  where
    (n, m)  =  snd $ bounds d
    abc  =  sort [a,b,c]
    solve' :: [Int] -> Int
    solve' xs  =  length [(i,j) | i <- [0..n-3], j <- [i+1..n-1],
        abc == sort [summ !! i, summ !! j - summ !! i, summ !! (n-1) - summ !! j]]
      where
        n  =  length xs
        summ  =  scanl1 (+) xs

parseLine :: Read a => String -> IO [a]
parseLine  =  return . map read . words

main :: IO ()
main  =  do
    hInput  <-  openFile "input.txt" ReadMode
    hOutput  <-  openFile "output.txt" WriteMode

    [n, m]  <-  hGetLine hInput >>= parseLine
    d  <-  mapM (\i -> hGetLine hInput >>= parseLine) [1..n]
    [a, b, c]  <-  hGetLine hInput >>= parseLine

    let res  =  solve (a,b,c) $ array ((1,1), (n,m)) [((i+1,j+1), d !! i !! j) | i <- [0..n-1], j <- [0..m-1]]

    hPrint hOutput res

    hClose hInput
    hClose hOutput


Two neighboring kingdoms decided to build a wall between them with some gates to enable the citizens to go from one kingdom to another. Each time a citizen passes through a gate, he has to pay one silver coin.The world can be represented by the first quadrant of a plane and the wall is built along the identity line (i.e. the line with the equation x = y). Any point below the wall belongs to the first kingdom while any point above the wall belongs to the second kingdom. There is a gate at any integer point on the line (i.e. at points (0, 0), (1, 1), (2, 2), ...). The wall and the gates do not belong to any of the kingdoms. Fafa is at the gate at position (0, 0) and he wants to walk around in the two kingdoms. He knows the sequence S of moves he will do. This sequence is a string where each character represents a move. The two possible moves Fafa will do are 'U' (move one step up, from (x, y) to (x, y + 1)) and 'R' (move one step right, from (x, y) to (x + 1, y)). Fafa wants to know the number of silver coins he needs to pay to walk around the two kingdoms following the sequence S. Note that if Fafa visits a gate without moving from one kingdom to another, he pays no silver coins. Also assume that he doesn't pay at the gate at point (0, 0), i. e. he is initially on the side he needs.

The first line of the input contains single integer n (1 ≤ n ≤ 105) — the number of moves in the walking sequence. The second line contains a string S of length n consisting of the characters 'U' and 'R' describing the required moves. Fafa will follow the sequence S in order from left to right.

On a single line, print one integer representing the number of silver coins Fafa needs to pay at the gates to follow the sequence S.

NoteThe figure below describes the third sample. The red arrows represent the sequence of moves Fafa will follow. The green gates represent the gates at which Fafa have to pay silver coins.

import Data.List

main = do
    temp <- getLine
    let n = read temp :: Int
    input <- getLine
    putStrLn $ show $ solve n input

step (a,b) 'R' = (a+1, b)
step (a,b) 'L' = (a-1, b)
step (a,b) 'U' = (a, b+1)
step (a,b) 'D' = (a, b-1)

solve n input =
    let
        cords = scanl step (0,0) input
        signs = filter (/=0) $ map (\(a,b) -> signum (a-b)) cords
        diffs = zipWith (-) signs (tail signs)
    in  (sum $ map abs diffs) `div` 2

module Main where

f _ _ n t [] = n
f u r n t (s:ss)
 | u == r && u /= 0 = f (if s == 'U' then u+1 else u)
                        (if s == 'R' then r+1 else r)
                        (if s == t then n+1 else n)
                        s
                        ss
 | s == 'U' = f (u+1) r n s ss
 | s == 'R' = f u (r+1) n s ss
 | otherwise = f u r n s ss

main = getLine >> getLine >>= print . f 0 0 0 '-'

f::Int->Int->Int->String->Int
f c x y ""=0
f c x y ('U':xs)=let t1=if x<y+1 && c==0 then 1 else 0
                     c2=if x<y+1 then 1 else 0
                 in t1 + f c2 x (y+1) xs
f c x y ('R':xs)=let t1=if y<x+1 && c==1 then 1 else 0
                     c2=if y<x+1 then 0 else 1
                 in t1+f c2 (x+1) y xs

main = do
       e<-getLine
       es<-getLine
       print $ f (-1) 0 0 es

toInt :: IO [Int]
toInt = fmap (map read.words) getLine

main = do
   n <- fmap head toInt
   s <- getLine
   putStrLn $ show $ f (0,0) (0,0) s

f :: (Integer,Integer) -> (Integer,Integer) -> String -> Int
f _ _ [] = 0
f (lastx,lasty) (x,y) (m:ms) = case m of
                                            'U' -> if (lastx-lasty)*(x-y-1)<0 then 1+(f (x,y) (x,y+1) ms)
                                                                            else f (x,y) (x,y+1) ms
                                            'R' -> if (lastx-lasty)*(x+1-y)<0 then 1+(f (x,y) (x+1,y) ms)
                                                                            else f (x,y) (x+1,y) ms

main = getContents >>= print . solve 0 0 0 . last . lines

solve cnt _ _ [] = cnt
solve cnt x y ('U':'U':cs) = if x - y == 1
  then solve (cnt + 1) x (y + 2) cs
  else solve cnt x (y + 1) ('U':cs)
solve cnt x y ('R':'R':cs) = if y - x == 1
  then solve (cnt + 1) (x + 2) y cs
  else solve cnt (x + 1) y ('R':cs)
solve cnt x y ('U':cs) = solve cnt x (y + 1) cs
solve cnt x y ('R':cs) = solve cnt (x + 1) y cs

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

import qualified Data.ByteString as B (getLine)
import qualified Data.ByteString.Char8 as C (readInt, words, unpack, reverse, dropWhile)
import qualified Data.Maybe as M (fromJust)
import Data.Char as C (isSpace)

readInt = fst . M.fromJust . C.readInt
rstrip = C.reverse . C.dropWhile C.isSpace . C.reverse

run r (x, y) (g:h:gs) | g == h && g == 'R' && x + 1 == y = run (r + 1) (x + 2, y) gs
                      | g == h && g == 'U' && x == y + 1 = run (r + 1) (x, y + 2) gs
run r (x, y) ('R':gs) = run r (x + 1, y) gs
run r (x, y) ('U':gs) = run r (x, y + 1) gs
run r (x, y) [] = r

main = do
    B.getLine
    (C.unpack . rstrip -> xxs) <- B.getLine
    putStrLn $ show $ run 0 (0, 0) xxs

f::Int->Int->String->Int
f x y ""=0
f x y (_:[])=0
f x y ('U':'U':xs)=let t = if y<x && x<y+2 then 1 else 0
                   in  t+f x (y+2) xs
f x y ('R':'R':xs)=let t = if x<y && y<x+2 then 1 else 0
                   in t+f (x+2) y xs
f x y ('U':xs)=f x (y+1) xs
f x y ('R':xs)=f (x+1) y xs

main = do
       e<-getLine
       es<-getLine
       print $ f 0 0 es

f::Int->Int->String->Int
f x y ""=0
f x y (_:[])=0
f x y ('U':'U':xs)=let t = if y<x && x<y+2 then 1 else 0
                   in  t+f x (y+1) xs
f x y ('R':'R':xs)=let t = if x<y && y<x+2 then 1 else 0
                   in t+f (x+1) y xs
f x y ('U':xs)=f x (y+1) xs
f x y ('R':xs)=f (x+1) y xs

main = do
       e<-getLine
       es<-getLine
       print $ f 0 0 es

toInt :: IO [Int]
toInt = fmap (map read.words) getLine

main = do
   n <- fmap head toInt
   s <- getLine
   putStrLn $ show $ f (0,0) (0,0) s

f :: (Int,Int) -> (Int,Int) -> String -> Int
f _ _ [] = 0
f (lastx,lasty) (x,y) (m:ms) = case m of
                                            'U' -> if (lastx-lasty)*(x-y-1)<0 then 1+(f (x,y) (x,y+1) ms)
                                                                            else f (x,y) (x,y+1) ms
                                            'R' -> if (lastx-lasty)*(x+1-y)<0 then 1+(f (x,y) (x+1,y) ms)
                                                                            else f (x,y) (x+1,y) ms


You play a computer game. Your character stands on some level of a multilevel ice cave. In order to move on forward, you need to descend one level lower and the only way to do this is to fall through the ice.The level of the cave where you are is a rectangular square grid of n rows and m columns. Each cell consists either from intact or from cracked ice. From each cell you can move to cells that are side-adjacent with yours (due to some limitations of the game engine you cannot make jumps on the same place, i.e. jump from a cell to itself). If you move to the cell with cracked ice, then your character falls down through it and if you move to the cell with intact ice, then the ice on this cell becomes cracked.Let's number the rows with integers from 1 to n from top to bottom and the columns with integers from 1 to m from left to right. Let's denote a cell on the intersection of the r-th row and the c-th column as (r, c). You are staying in the cell (r1, c1) and this cell is cracked because you've just fallen here from a higher level. You need to fall down through the cell (r2, c2) since the exit to the next level is there. Can you do this?

The first line contains two integers, n and m (1 ≤ n, m ≤ 500) — the number of rows and columns in the cave description. Each of the next n lines describes the initial state of the level of the cave, each line consists of m characters "." (that is, intact ice) and "X" (cracked ice). The next line contains two integers, r1 and c1 (1 ≤ r1 ≤ n, 1 ≤ c1 ≤ m) — your initial coordinates. It is guaranteed that the description of the cave contains character 'X' in cell (r1, c1), that is, the ice on the starting cell is initially cracked. The next line contains two integers r2 and c2 (1 ≤ r2 ≤ n, 1 ≤ c2 ≤ m) — the coordinates of the cell through which you need to fall. The final cell may coincide with the starting one.

If you can reach the destination, print 'YES', otherwise print 'NO'.

NoteIn the first sample test one possible path is:After the first visit of cell (2, 2) the ice on it cracks and when you step there for the second time, your character falls through the ice as intended.

import Data.Array.IO
import Data.IORef
import Data.Ix
import Control.Monad
dfs mat bound now end = do
  fl <- readArray mat now
  if fl=='H'
  then if (now == end)
       then return True
       else do
         writeArray mat now 'X'
         return False
  else do
    let i = fst now
    let j = snd now
    isok <- newIORef False
    forM_ [(i-1,j),(i,j-1),(i+1,j),(i,j+1)] $ \next -> do
      tmp <- readIORef isok
      when (inRange bound next && tmp == False) $ do
        nfl <- readArray mat next
        writeArray mat next (nextState nfl)
        b <- dfs mat bound next end
        when (b) $ writeIORef isok True
    isokt <- readIORef isok
    return isokt
nextState '.' = 'X'
nextState 'X' = 'H'
readInts s = [read n::Int|n <- (words s)]
main = do
  w0 <- getLine
  let [si,sj] = readInts w0
  ss <- replicateM si getLine
  w1 <- getLine
  w2 <- getLine
  let [s0,s1] = readInts w1
  let [e0,e1] = readInts w2
  let start = (s0,s1)
  let end = (e0,e1)
  mat <- newListArray ((1,1),(si,sj)) (concat ss) ::IO (IOArray (Int,Int) Char)
  b <- dfs mat ((1,1),(si,sj)) start end
  putStrLn $ if b then "YES" else "NO"

import Data.Array
import Data.Graph
toGraph::Array Int (Array Int Bool) -> (Int,Int) -> Graph
toGraph a s = listArray (0,si*sj-1) [getList i j si sj a | i<-[0..(si-1)],j<-[0..(sj-1)]]
          where si = fst s
                sj = snd s
toInt::Int -> Int -> Int -> Int -> Int
toInt i j si sj = i*sj+j
getList i j si sj a = (getN i j (-1) 0 si sj a) ++ (getN i j 1 0 si sj a) ++ (getN i j 0 (-1) si sj a) ++ (getN i j 0 1 si sj a)
getN i j di dj si sj a = if (isIn (i+di) (j+dj) si sj)&&(get (i+di) (j+dj) a) then [toInt (i+di) (j+dj) si sj] else []
isIn di dj si sj = 0<= di && di < si && 0<=dj && dj < sj
get::Int -> Int -> Array Int (Array Int Bool) -> Bool
get i j a = (a ! i) ! j
readStringList::Int -> IO [String]
readStringList 0 = return []
readStringList n = do
  w <- getLine
  next <- readStringList (n-1)
  return ([w]++next)
readIntTuple::IO (Int,Int)
readIntTuple = do
  w <- getLine
  let a = [read n::Int|n <- (words w)]
  return ((a !! 0),(a !! 1))
toNotBools j ej sj s | j == sj = []
                     | j /= ej = [hs == '.'] ++ next
                     | otherwise = [True] ++ next
                        where hs = head s
                              ts = tail s
                              next = toNotBools (j+1) ej sj ts
toBools i ei ej si sj s| i == si = []
                       | i /= ei = [toBool hs] ++ next
                       | otherwise = [tb] ++ next
                                     where ts = tail s
                                           hs = head s
                                           tb = toNotBools 0 ej sj hs
                                           next = toBools (i+1) ei ej si sj ts
toBool s = map (\x -> x=='.') s
main = do
  size <- readIntTuple
  m <- readStringList (fst size)
  start <- readIntTuple
  end <- readIntTuple
  let bm = toBools 0 ((fst end)-1) ((snd end)-1) (fst size) (snd size) m
  let a = listArray (0,(fst size)-1) $ (map ((listArray (0,(snd size) -1))) bm)
  let s = toInt ((fst start)-1) ((snd start) -1) (fst size) (snd size)
  let e = toInt ((fst end) -1) ((snd end) -1) (fst size) (snd size)
  let b = ((m !! ((fst end) - 1)) !! ((snd end) -1)) == '.'
  let g = toGraph a size
  let r = reachable g s
  let isok = if b then (length (g ! e)) >= 2 else True
  putStrLn $ if elem e r && isok then "YES" else "NO"

import Data.Array
import Data.Graph
toGraph::Array Int (Array Int Bool) -> (Int,Int) -> Graph
toGraph a s = listArray (0,si*sj-1) [getList i j si sj a | i<-[0..(si-1)],j<-[0..(sj-1)]]
          where si = fst s
                sj = snd s
toInt::Int -> Int -> Int -> Int -> Int
toInt i j si sj = i*sj+j
getList i j si sj a = (getN i j (-1) 0 si sj a) ++ (getN i j 1 0 si sj a) ++ (getN i j 0 (-1) si sj a) ++ (getN i j 0 1 si sj a)
getN i j di dj si sj a = if (isIn (i+di) (j+dj) si sj)&&(get (i+di) (j+dj) a) then [toInt (i+di) (j+dj) si sj] else []
isIn di dj si sj = 0<= di && di < si && 0<=dj && dj < sj
get::Int -> Int -> Array Int (Array Int Bool) -> Bool
get i j a = (a ! i) ! j
readStringList::Int -> IO [String]
readStringList 0 = return []
readStringList n = do
  w <- getLine
  next <- readStringList (n-1)
  return ([w]++next)
readIntTuple::IO (Int,Int)
readIntTuple = do
  w <- getLine
  let a = [read n::Int|n <- (words w)]
  return ((a !! 0),(a !! 1))
toNotBools j ej sj s | j == sj = []
                     | j /= ej = [hs == '.'] ++ next
                     | otherwise = [True] ++ next
                        where hs = head s
                              ts = tail s
                              next = toNotBools (j+1) ej sj ts
toBools i ei ej si sj s| i == si = []
                       | i /= ei = [toBool hs] ++ next
                       | otherwise = [tb] ++ next
                                     where ts = tail s
                                           hs = head s
                                           tb = toNotBools 0 ej sj hs
                                           next = toBools (i+1) ei ej si sj ts
toBool s = map (\x -> x=='.') s
main = do
  size <- readIntTuple
  m <- readStringList (fst size)
  start <- readIntTuple
  end <- readIntTuple
  let bm = toBools 0 ((fst end)-1) ((snd end)-1) (fst size) (snd size) m
  let a = listArray (0,(fst size)-1) $ (map ((listArray (0,(snd size) -1))) bm)
  let s = toInt ((fst start)-1) ((snd start) -1) (fst size) (snd size)
  let e = toInt ((fst end) -1) ((snd end) -1) (fst size) (snd size)
  let b = ((m !! ((fst end) - 1)) !! ((snd end) -1)) == '.'
  let g = toGraph a size
  let r = reachable g s
  let isok = if b then (length (g ! e)) >= 2 else True
  if (fst size) == 1 && (snd size) == 1 then putStrLn "NO" else putStrLn $ if elem e r && isok then "YES" else "NO"


Alice got tired of playing the tag game by the usual rules so she offered Bob a little modification to it. Now the game should be played on an undirected rooted tree of n vertices. Vertex 1 is the root of the tree.Alice starts at vertex 1 and Bob starts at vertex x (x ≠ 1). The moves are made in turns, Bob goes first. In one move one can either stay at the current vertex or travel to the neighbouring one.The game ends when Alice goes to the same vertex where Bob is standing. Alice wants to minimize the total number of moves and Bob wants to maximize it.You should write a program which will determine how many moves will the game last.

The first line contains two integer numbers n and x (2 ≤ n ≤ 2·105, 2 ≤ x ≤ n). Each of the next n - 1 lines contains two integer numbers a and b (1 ≤ a, b ≤ n) — edges of the tree. It is guaranteed that the edges form a valid tree.

Print the total number of moves Alice and Bob will make.

NoteIn the first example the tree looks like this:  The red vertex is Alice's starting position, the blue one is Bob's. Bob will make the game run the longest by standing at the vertex 3 during all the game. So here are the moves:B: stay at vertex 3A: go to vertex 2B: stay at vertex 3A: go to vertex 3In the second example the tree looks like this:  The moves in the optimal strategy are:B: go to vertex 3A: go to vertex 2B: go to vertex 4A: go to vertex 3B: stay at vertex 4A: go to vertex 4

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -funfolding-use-threshold=16 -fexcess-precision -funbox-strict-fields #-}
module Main where
import qualified Data.ByteString.Lazy.Char8 as B
import Control.Monad
import Control.Monad.Trans.State.Lazy
import Data.Array.Unboxed
import Data.List

main = putStr . evalState app . B.words =<< B.getContents

app = do
  n <- poi
  x <- poi
  es <- replicateM (n - 1) $ liftM2 (,) poi poi
  return $ show $ solve n x es
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve n x es = (2*) $ maximum $ map (lowestOf!) $ takeWhile (\u -> depthOf!u - depthOf!1 > depthOf!x - depthOf!u) $ iterate (parentOf!) x
  where
    g = accumArray (flip (:)) [] (1, n) $ concat [[(u, v), (v, u)] | (u, v) <- es] :: Array Int [Int]
    depthOf = array (1, n) $ dfs g (\u cs d -> ((u, d):) . foldl' (\p f -> p . f (d + 1)) id cs) 0 [] :: UArray Int Int
    parentOf = array (1, n) $ dfs g (\u cs p -> ((u, p):) . foldl' (\p f -> p . f u) id cs) 0 [] :: UArray Int Int
    lowestOf = array (1, n) $ ($ []) $ snd $ dfs g (\u cs -> let l = maximum $ (depthOf!u):map fst cs in (l, ((u, l):) . foldl' (\p f -> p . snd f) id cs)) :: UArray Int Int

dfs :: Array Int [Int] -> (Int -> [b] -> b) -> b
dfs g f = go 0 1
  where go p u = f u $ map (go u) $ filter (/= p) (g!u)

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -funfolding-use-threshold=16 -fexcess-precision -funbox-strict-fields #-}
module Main where
import qualified Data.ByteString.Lazy.Char8 as B
import Control.Monad
import Control.Monad.Trans.State.Lazy
import Data.Array.Unboxed

main = putStr . evalState app . B.words =<< B.getContents

app = do
  n <- poi
  x <- poi
  es <- replicateM (n - 1) $ liftM2 (,) poi poi
  return $ show $ solve n x es
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve n x es = (2*) $ maximum $ map (lowestOf!) $ takeWhile (\u -> depthOf!u - depthOf!1 > depthOf!x - depthOf!u) $ iterate (parentOf!) x
  where
    g = accumArray (flip (:)) [] (1, n) $ concat [[(u, v), (v, u)] | (u, v) <- es] :: Array Int [Int]
    depthOf = array (1, n) $ dfs g (\u cs d -> ((u, d):) . foldr ( (.) . ($ d + 1)) id cs) 0 [] :: UArray Int Int
    parentOf = array (1, n) $ dfs g (\u cs p -> ((u, p):) . foldr ((.) . ($ u)) id cs) 0 [] :: UArray Int Int
    lowestOf = array (1, n) $ ($ []) $ snd $ dfs g (\u cs -> let l = maximum $ (depthOf!u):map fst cs in (l, ((u, l):) . foldr ((.) . snd) id cs)) :: UArray Int Int

dfs :: Array Int [Int] -> (Int -> [b] -> b) -> b
dfs g f = go 0 1
  where go p u = f u $ map (go u) $ filter (/= p) (g!u)

module Main where
import qualified Data.ByteString.Char8 as B
import Control.Monad
import Control.Applicative
import Data.Array.Unboxed
import Data.List
import Data.Ord
import Data.Maybe

readInt = fst . fromJust . B.readInt
readInts = fmap readInt . B.words

maximaBy f xs = filter (\x -> f x m == EQ) xs
  where m = maximumBy f xs

solve n x es = 2 * max aCnt bCnt
  where
    g = accumArray (flip (:)) [] (1, n) $ concat [[(u, v), (v, u)] | (u, v) <- es] :: Array Int [Int]
    aCnt = depthOf!head deepestUs - depthOf!1
    bCnt
      | x `elem` deepestUs = 0
      | otherwise = minimum $ map (\u -> depthOf!u + depthOf!x - 2 * depthOf!lca u x) deepestUs
    deepestUs = map fst $ maximaBy (comparing snd) $ assocs depthOf
    depthOf = array (1, n) $ dfs (\u cs d -> (u, d) : concatMap ($ d + 1) cs) (const []) 0 :: UArray Int Int
    lca a b = fromJust $ dfs go Nothing
      where
        go u cs
          | u == a || u == b = Just u
          | otherwise = case filter isJust cs of
              [v] -> v
              [_, _] -> Just u
              _ -> Nothing
          | otherwise = foldl (<|>) mzero cs
    dfs f z = go 0 1
      where
        go p u = case filter (/= p) (g!u) of
          [] -> f u [z]
          vs -> f u $ map (go u) vs

main = do
  [n, x] <- fmap readInts B.getLine
  es <- replicateM (n - 1) (fmap ((\(u:v:_) -> (u, v)) . readInts) B.getLine)
  print $ solve n x es

module Main where
import qualified Data.ByteString.Char8 as B
import Control.Monad
import Control.Applicative
import Data.Array.Unboxed
import Data.List
import Data.Ord
import Data.Maybe

readInt = fst . fromJust . B.readInt
readInts = fmap readInt . B.words

maximaBy f xs = filter (\x -> f x m == EQ) xs
  where m = maximumBy f xs

solve n x es = g -- 2 * max aCnt bCnt
  where
    g = accumArray (flip (:)) [] (1, n) $ concat [[(u, v), (v, u)] | (u, v) <- es] :: Array Int [Int]
    aCnt = depthOf!head deepestUs - depthOf!1
    bCnt
      | x `elem` deepestUs = 0
      | otherwise = minimum $ map (\u -> depthOf!u + depthOf!x - 2 * depthOf!lca u x) deepestUs
    deepestUs = map fst $ maximaBy (comparing snd) $ assocs depthOf
    depthOf = array (1, n) $ dfs (\u cs d -> (u, d) : concatMap ($ d + 1) cs) (const []) 0 :: UArray Int Int
    lca a b = fromJust $ dfs go Nothing
      where
        go u cs
          | u == a || u == b || all isJust cs = Just u
          | otherwise = foldl (<|>) mzero cs
    dfs f z = go 0 1
      where
        go p u = case filter (/= p) (g!u) of
          [] -> f u [z]
          vs -> f u $ map (go u) vs

main = do
  [n, x] <- fmap readInts B.getLine
  es <- replicateM (n - 1) (fmap ((\(u:v:_) -> (u, v)) . readInts) B.getLine)
  print $ solve n x es


You've got string s, consisting of only lowercase English letters. Find its lexicographically maximum subsequence.We'll call a non-empty string s[p1p2... pk] = sp1sp2... spk(1 ≤ p1 < p2 < ... < pk ≤ |s|) a subsequence of string s = s1s2... s|s|.String x = x1x2... x|x| is lexicographically larger than string y = y1y2... y|y|, if either |x| > |y| and x1 = y1, x2 = y2, ... , x|y| = y|y|, or exists such number r (r < |x|, r < |y|), that x1 = y1, x2 = y2, ... , xr = yr and xr + 1 > yr + 1. Characters in lines are compared like their ASCII codes.

The single line contains a non-empty string s, consisting only of lowercase English letters. The string's length doesn't exceed 105.

Print the lexicographically maximum subsequence of string s.

NoteLet's look at samples and see what the sought subsequences look like (they are marked with uppercase bold letters).The first sample: aBaBBAThe second sample: abbCbCCaCbbCBaaBA

f :: String -> String
f s
	| null s=[]
	| null y=[x]
	| x >= (head y)=x:y
	| otherwise = y
	where (x,y) = (head s,f $ tail s)
main = do
	s <- getLine
	putStrLn $ f s

f s
	| null s=[]
	| null y=[x]
	| x >= (head y)=x:y
	| True = y
	where (x,y) = (head s,f $ tail s)
main = do
	s <- getLine
	putStrLn $ f s

solve :: String -> String
solve s  =  reverse $ (head s') : solve' (head s') (tail s')
  where
    s'  =  reverse s
    solve' p []  =  []
    solve' p (c:s)
      | p > c  =  solve' p s
      | otherwise  =  c : solve' c s

main :: IO ()
main  =  getLine >>= putStrLn . solve

solve :: String -> String
solve "" = ""
solve s = filter (== max) s ++ solve rest
          where
            max = maximum s
            rest = reverse . takeWhile (/= max) $ reverse s

main :: IO ()
main = do
  s <- getLine
  putStrLn $ solve s

x#[]=[x]
x#y|x<head y=y|1>0=x:y
main=interact$foldr(#)[]

main = getLine >>= putStrLn.solve 'a' [].reverse

solve c ans [] = ans
solve c ans (x:xs)
  | c<=x = solve x (x:ans) xs
  | otherwise = solve c ans xs


Ksusha is a beginner coder. Today she starts studying arrays. She has array a1, a2, ..., an, consisting of n positive integers.Her university teacher gave her a task. Find such number in the array, that all array elements are divisible by it. Help her and find the number!

The first line contains integer n (1 ≤ n ≤ 105), showing how many numbers the array has. The next line contains integers a1, a2, ..., an (1 ≤ ai ≤ 109) — the array elements.

Print a single integer — the number from the array, such that all array elements are divisible by it. If such number doesn't exist, print -1. If there are multiple answers, you are allowed to print any of them.

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

main = do
	getLine
	(a:as) <- sort . map read . words <$> getLine
	print $ if all ( ( == 0 ) . ( `mod` a ) ) as then a else -1

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

main = do
	getLine
	(a:as) <- sort . map read . words <$> getLine
	print $ if solve a as then a else -1

solve n [] = True
solve n (a:as)
	| mod a n == 0 = solve n as
	| otherwise = False

main = do
    a <- map (read :: String -> Int ) . words  <$> (getLine >> getLine)
    let b = foldr1 gcd a
    print $ if b `elem` a then b else -1

import Data.List

verify k []     = k
verify k (x:xs) = if x `mod` k == 0 then verify k xs else -1

check (x:xs) = verify x xs

main = interact $ show . check . sort . map read . tail . words

import Data.List

verify k []     = k
verify k (x:xs) = if x `mod` k == 0 then verify k xs else -1

check (x:xs) = verify x xs

unique ::[Int] -> [Int]
unique [] = []
unique [x] = [x]
unique (x:y:xs) = if x /= y then x : (unique $ y: xs) else unique $ y: xs

main = interact $ show . check . unique . sort . map read . tail . words

import Control.Monad (liftM)
import Prelude hiding (reads)

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

solve :: [Int] -> Int
solve as
  | all ((== 0) . flip mod min) as  =  min
  | otherwise  =  -1
  where
    min  =  minimum as

main :: IO ()
main  =  do
    getLine
    as  <-  reads
    print $ solve as

import Data.List
main::IO()
main=do
	n<-getLine
	input<-getLine
	let
		(x:a)=sort $ map read (words input)::[Int]
		is=foldl (\a b -> a && b `mod` x ==0 ) True a
	print $ if is then x else -1

import Data.List (foldl')

main = getLine >> fmap (solve.map read.words) getLine >>= print

solve :: [Integer] -> Integer
solve xs = foldl' f ans xs
   where ans = minimum xs
         f (-1) _ = -1
         f ans next | mod next ans == 0 = ans
                    | otherwise = -1

import Data.List (foldl')

main = getLine >> fmap (solve.map read.words) getLine >>= print

solve :: [Integer] -> Integer
solve xs = if isP then ans else -1
   where (isP, ans) = foldl' f (True, head xs) (tail xs)
         f (isP', ans') next | g == next = (True, g)
                             | g == ans' = (isP', g)
                             | otherwise = (False, g)
            where g = gcd ans' next

main = getLine >> getLine >>= print . foldr1 gcd . map (read :: String -> Int ) . words

main = do
    a <- map (read :: String -> Int ) . words  <$> (getLine >> getLine)
    let b = foldr1 gcd a
    print $ if b /= 1 || (b == 1 && 1 `elem` a) then b else -1

import Data.List

verify k []     = k
verify k (x:xs) = if x `mod` k == 0 then verify k xs else -1

check (x:xs) = verify x xs

unique ::[Int] -> [Int]
unique [] = []
unique [x] = [x]
unique (x:y:xs) = if x /= y then x : (unique $ y: xs) else unique $ y: xs

-- main = interact $ show . check . unique . sort . map read . tail . words
main = interact $ show . unique . sort . map read . tail . words

import Data.List (foldl')

main = getLine >> fmap (solve.map read.words) getLine >>= print

solve :: [Int] -> Int
solve xs = foldl' f (head xs) (tail xs)
   where f (-1) _ = -1
         f current next | mod next current == 0 = current
                        | mod current next == 0 = next
                        | otherwise = -1