Little boy Gerald studies at school which is quite far from his house. That's why he has to go there by bus every day. The way from home to school is represented by a segment of a straight line; the segment contains exactly n + 1 bus stops. All of them are numbered with integers from 0 to n in the order in which they follow from Gerald's home. The bus stop by Gerald's home has number 0 and the bus stop by the school has number n.There are m buses running between the house and the school: the i-th bus goes from stop si to ti (si < ti), visiting all the intermediate stops in the order in which they follow on the segment. Besides, Gerald's no idiot and he wouldn't get off the bus until it is still possible to ride on it closer to the school (obviously, getting off would be completely pointless). In other words, Gerald can get on the i-th bus on any stop numbered from si to ti - 1 inclusive, but he can get off the i-th bus only on the bus stop ti.Gerald can't walk between the bus stops and he also can't move in the direction from the school to the house.Gerald wants to know how many ways he has to get from home to school. Tell him this number. Two ways are considered different if Gerald crosses some segment between the stops on different buses. As the number of ways can be too much, find the remainder of a division of this number by 1000000007 (109 + 7).

The first line contains two space-separated integers: n and m (1 ≤ n ≤ 109, 0 ≤ m ≤ 105). Then follow m lines each containing two integers si, ti. They are the numbers of starting stops and end stops of the buses (0 ≤ si < ti ≤ n).

Print the only number — the number of ways to get to the school modulo 1000000007 (109 + 7).

NoteThe first test has the only variant to get to school: first on bus number one to the bus stop number one; then on bus number two to the bus stop number two.In the second test no bus goes to the third bus stop, where the school is positioned. Thus, the correct answer is 0.In the third test Gerald can either get or not on any of the first four buses to get closer to the school. Thus, the correct answer is 24 = 16.

{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE BangPatterns #-}

{- based on submission 2997762 by Dabek -}

import Control.Monad
import Data.Array (Array)
import Data.Array.MArray
import Data.Array.IO
import Data.Array.Unboxed (UArray)
import Data.Array.IArray ((!),bounds)
import qualified Data.Array.MArray as M
import Data.List
import Data.Ord
import Debug.Trace
import qualified Data.ByteString.Char8 as BS
import Data.ByteString (ByteString)
import Data.Char
import Text.Printf
import Data.Time.Clock (getCurrentTime,diffUTCTime)

{- -O2 provides small, but noticable benefit for qsort. -}
-- Copyright  2010 Bart Massey
-- Copyright  2012 Petr Pudlak

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

{-# INLINE insertsort #-}
insertsort :: (MArray a e m, Ord e) => a Int e -> m ()
insertsort a = getBounds a >>= uncurry (insertsort' (return ()) a)

{-# INLINE insertsort' #-}
insertsort' :: (MArray a e m, Ord e) => m () -> a Int e -> Int -> Int -> m ()
insertsort' cmpaction a mn mx = srt (mn + 1)
  where
    srt i = when (i <= mx) $ do
                v <- readArray a i
                j <- hole v i
                when (i /= j) (writeArray a j v)
                srt (i + 1)
    hole v = hole'
      where
        hole' i | i == mn     = return i
                | otherwise   = do
                    let i' = i - 1
                    u <- readArray a i'
                    cmpaction
                    if v < u
                      then writeArray a i u >> hole' i'
                      else return i

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

-- Internally, heap indices are transformed
-- to be zero-based.

data NodeType = Inner | Leaf | Edge

{-# INLINE heapsort #-}
heapsort :: (Integral i, Ix i, Ord e, MArray a e m) => a i e -> m ()
-- | Sort the elements of the given 'MArray' in increasing order.
heapsort a = getBounds a >>= uncurry (heapsort' a)

{-# INLINE heapsort' #-}
heapsort' :: (Integral i, Ix i, Ord e, MArray a e m) => a i e -> i -> i -> m ()
-- | Sort the elements of the given 'MArray' in increasing order.
heapsort' a mn mx = do
    heapify
    extract
  where
    getN = mx - mn + 1

    {-# INLINE right #-}
    right i = 2 * i + 2

    {-# INLINE nodeType #-}
    nodeType n i = case compare (right i) n of
        GT  -> Leaf
        EQ  -> Edge
        LT  -> Inner

    {-# INLINE atIndex #-}
    atIndex i = readArray a (i + mn)

    {-# INLINE atIndexW #-}
    atIndexW i = writeArray a (i + mn)

    {-# INLINE downHeap #-}
    downHeap n j = do
        c <- atIndex j
        dh c j
      where
        -- Propagate @c@ down the heap. We only move elements up as we walk on
        -- the nodes, and when we're finished, we write @c@ to the last node.
        -- This way we save half of read/writes, compared to swapping elements.
        dh c = dhStep
          where
            dhStep i = case nodeType n i of
                Leaf -> stop
                Edge -> do
                    l <- atIndex il
                    if c < l
                      then atIndexW i l >> atIndexW il c
                      else stop
                Inner -> do
                    l <- atIndex il
                    r <- atIndex ir
                    if c >= l && c >= r
                      then stop
                      else if l >= r
                        then atIndexW i l >> dhStep il
                        else atIndexW i r >> dhStep ir
              where
                {-# INLINE stop #-}
                stop = when (i /= j) (atIndexW i c)
                ir = right i
                il = ir - 1

    {-# INLINE heapify #-}
    heapify = heapifyRoots (n - 1) -- optimize: use 2^k such that k is maximal that 2^k < n
      where
        n = getN
        heapifyRoots i | i < 0  = return ()
                       | otherwise = downHeap n i >> heapifyRoots (i - 1)

    {-# INLINE exch #-}
    exch ix1 ix2 | ix1 == ix2   = return ()
                 | otherwise    = do
      let i = ix1 + mn
          j = ix2 + mn
      v1 <- readArray a i
      v2 <- readArray a j
      writeArray a j v1
      writeArray a i v2

    {-# INLINE extract #-}
    extract = extractRoot (getN - 1)
      where
        extractRoot k | k <= 0    = return ()
                      | otherwise = do
            exch k 0
            downHeap k 0
            extractRoot (k - 1)

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

insertsortLimit :: Int
insertsortLimit = 32

depthCoeficient :: Double
depthCoeficient = 2 / log 2

{-# INLINE qsort #-}
qsort :: (MArray a e m, Ord e) => a Int e -> m ()
qsort = introsort' (return ()) ( -1 )

{-# INLINE maxQSortDepth #-}
maxQSortDepth :: (MArray a e m) => a Int e -> m Int
maxQSortDepth arr = do
    (mn, mx) <- getBounds arr
    return $ ceiling (depthCoeficient * log (fromIntegral $ mx - mn + 1))

{-# INLINE introsort #-}
introsort :: (MArray a e m, Ord e) => a Int e -> m ()
introsort arr = maxQSortDepth arr >>= \d -> introsort' (return ()) d arr

{-# INLINE introsort' #-}
introsort' :: (MArray a e m, Ord e) => m () -> Int -> a Int e -> m ()
introsort' cmpaction maxdepth a = getBounds a >>= uncurry (srt maxdepth)
  where
    srt depthleft mn mx
        | depthleft == 0             = heapsort' a mn mx
        | mn + insertsortLimit > mx  = insertsort' cmpaction a mn mx
        | otherwise = do
                -- Select a pivot - median of 3:
                pL <- readArray a mn
                pR <- readArray a mx
                let d = (mn + mx) `div` 2
                pD <- readArray a d
                cmpaction
                let (_, pidx) = median3 (pR, mx) (pD, d) (pL, mn)

                p <- swap d mn
                i <- split p (mn + 1) mx
                swap i mn

                let depthleft' = depthleft - 1
                -- Sort the smaller part first. Hopefully, tail
                -- recursion will catch on the larger part and so we'll
                -- have guaranteed that even in the worst case, we'll
                -- have at most (log n) calls on the stack.
                if i < d then do
                    srt depthleft' mn (i - 1)
                    srt depthleft' (i + 1) mx
                 else do
                    srt depthleft' (i + 1) mx
                    srt depthleft' mn (i - 1)
      where
        {-# INLINE swap #-}
        swap i j = do
            u <- readArray a i
            when (i /= j) $ do
                v <- readArray a j
                writeArray a i v
                writeArray a j u
            return u
        {-# INLINE split #-}
        split p = split'
          where
            split' i j = do
              i' <- moveRight i
              j' <- moveLeft j
              if i' < j'
                then swap i' j' >> split' (i' + 1) (j' - 1)
                else return j'
              where
                moveRight i | i > j = return i
                            | otherwise = do
                    v <- readArray a i
                    cmpaction
                    if v >= p
                        then return i
                        else moveRight (i + 1)
                moveLeft j | i > j = return j
                           | otherwise = do
                    v <- readArray a j
                    cmpaction
                    if v <= p
                        then return j
                        else moveLeft (j - 1)

{-# INLINE median3 #-}
median3 :: Ord a => a -> a -> a -> a
median3 a b c
    | a > b     = sel a b
    | otherwise = sel b a
  where
    sel l s | c > l     = l
            | c < s     = s
            | otherwise = c

-- ---------------------------
bigPrime = 10^(9::Int)+7 :: Int

newtype Modular = M { unModular :: Int }
  deriving (Show)

instance Num Modular where
  fromInteger x = M $ mod (fromInteger x) bigPrime
  (M x) + (M y) = M $ mod (x+y) bigPrime
  (M x) * (M y) = M $ mod (x*y) bigPrime
  (M x) - (M y) = M $ mod (x-y) bigPrime
  abs = undefined
  signum = undefined

readInt :: IO Int
readInt = do line <- BS.getLine
             let Just (n,_) = BS.readInt line
             return n

parseInts :: Int -> ByteString -> [Int]
parseInts k bs | k <= 0 = []
parseInts k bs = case BS.readInt (BS.dropWhile isSpace bs) of
                   Nothing -> []
                   Just (n,bs') -> n : parseInts (k-1) bs'

{-
  c[1] = 1
  c[ y ] = sum [ c[x] | (s,t) <- buses, t == y, (s',x) <- buses, x in [s,t-1] ]
  (1,2) (2,100) (100,200)
-}

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

inc arr i b = do v <- readArray arr i; writeArray arr i (v+b)

showArray label arr = do
  let (lo,hi) = bounds arr
  putStr $ label ++ ": "
  forM_ [lo..hi] $ \i -> do putStr $ printf "%3d " (arr!i)
  putStrLn ""

showTime start label = do
  now <- getCurrentTime
  let diff = diffUTCTime now start
  putStrLn $ label ++ ": " ++ show diff

-- return the first index i s.t. pred (arr!i) is True
lowerBound arr a b pred = go a (b-a)
  where go a count =
          if count > 0
            then let mid = a + step
                     step = div count 2
                 in if pred (arr!mid) then go a step
                                      else go (mid+1) (count-step-1)
            else a

solve n 0 = return 0
solve n m = do
  -- start <- getCurrentTime
  let mark label = return () -- showTime start label
      m' = m+1
  arr <- newArray (0,m') (0,0) :: IO (IOArray Int (Int,Int))

  writeArray arr 0 (0,-1)
  forM_ [1..m] $ \i -> do
    (a:b:_) <- fmap (parseInts 2) BS.getLine
    writeArray arr i (b,a)
  writeArray arr m' (n+1,n)
  mark "read buses"

  qsort arr
  arr <- M.freeze arr :: IO (Array Int (Int,Int))

  -- putStrLn $ show $ arr ! (m-1)
  mark "sorted"

  res    <- newArray (0,m')   0 :: IO (IOUArray Int Int)
  prefix <- newArray (0,m'+1) 0 :: IO (IOUArray Int Int)
  mark "newArray"

  writeArray prefix 1 1
  writeArray res 1 1
  forM_ [1..m'] $ \i -> do
    let (t,s) = arr!i
        left  = lowerBound arr 0 i (\(t',s') -> t' >= s)
        right = lowerBound arr 0 i (\(t',s') -> t' >= t)
    pr <- readArray prefix right
    pl <- readArray prefix left
    writeArray res    i     (mod (pr-pl)    bigPrime)
    pi <- readArray prefix i
    writeArray prefix (i+1) (mod (pi+pr-pl) bigPrime)

  readArray res m'

main = do
  (n:m:_) <- getIntList
  answer <- solve n m
  print answer

{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE BangPatterns #-}

import Control.Monad
import Data.Array (Array)
import Data.Array.MArray
import Data.Array.IO
import Data.Array.Unboxed (UArray)
import Data.Array.IArray ((!),bounds)
import qualified Data.Array.MArray as M
import Data.List
import Data.Ord
import Debug.Trace
import qualified Data.ByteString.Char8 as BS
import Data.ByteString (ByteString)
import Data.Char
import Text.Printf
import Data.Time.Clock (getCurrentTime,diffUTCTime)

{- -O2 provides small, but noticable benefit for qsort. -}
-- Copyright  2010 Bart Massey
-- Copyright  2012 Petr Pudlak

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

{-# INLINE insertsort #-}
insertsort :: (MArray a e m, Ord e) => a Int e -> m ()
insertsort a = getBounds a >>= uncurry (insertsort' (return ()) a)

{-# INLINE insertsort' #-}
insertsort' :: (MArray a e m, Ord e) => m () -> a Int e -> Int -> Int -> m ()
insertsort' cmpaction a mn mx = srt (mn + 1)
  where
    srt i = when (i <= mx) $ do
                v <- readArray a i
                j <- hole v i
                when (i /= j) (writeArray a j v)
                srt (i + 1)
    hole v = hole'
      where
        hole' i | i == mn     = return i
                | otherwise   = do
                    let i' = i - 1
                    u <- readArray a i'
                    cmpaction
                    if v < u
                      then writeArray a i u >> hole' i'
                      else return i

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

-- Internally, heap indices are transformed
-- to be zero-based.

data NodeType = Inner | Leaf | Edge

{-# INLINE heapsort #-}
heapsort :: (Integral i, Ix i, Ord e, MArray a e m) => a i e -> m ()
-- | Sort the elements of the given 'MArray' in increasing order.
heapsort a = getBounds a >>= uncurry (heapsort' a)

{-# INLINE heapsort' #-}
heapsort' :: (Integral i, Ix i, Ord e, MArray a e m) => a i e -> i -> i -> m ()
-- | Sort the elements of the given 'MArray' in increasing order.
heapsort' a mn mx = do
    heapify
    extract
  where
    getN = mx - mn + 1

    {-# INLINE right #-}
    right i = 2 * i + 2

    {-# INLINE nodeType #-}
    nodeType n i = case compare (right i) n of
        GT  -> Leaf
        EQ  -> Edge
        LT  -> Inner

    {-# INLINE atIndex #-}
    atIndex i = readArray a (i + mn)

    {-# INLINE atIndexW #-}
    atIndexW i = writeArray a (i + mn)

    {-# INLINE downHeap #-}
    downHeap n j = do
        c <- atIndex j
        dh c j
      where
        -- Propagate @c@ down the heap. We only move elements up as we walk on
        -- the nodes, and when we're finished, we write @c@ to the last node.
        -- This way we save half of read/writes, compared to swapping elements.
        dh c = dhStep
          where
            dhStep i = case nodeType n i of
                Leaf -> stop
                Edge -> do
                    l <- atIndex il
                    if c < l
                      then atIndexW i l >> atIndexW il c
                      else stop
                Inner -> do
                    l <- atIndex il
                    r <- atIndex ir
                    if c >= l && c >= r
                      then stop
                      else if l >= r
                        then atIndexW i l >> dhStep il
                        else atIndexW i r >> dhStep ir
              where
                {-# INLINE stop #-}
                stop = when (i /= j) (atIndexW i c)
                ir = right i
                il = ir - 1

    {-# INLINE heapify #-}
    heapify = heapifyRoots (n - 1) -- optimize: use 2^k such that k is maximal that 2^k < n
      where
        n = getN
        heapifyRoots i | i < 0  = return ()
                       | otherwise = downHeap n i >> heapifyRoots (i - 1)

    {-# INLINE exch #-}
    exch ix1 ix2 | ix1 == ix2   = return ()
                 | otherwise    = do
      let i = ix1 + mn
          j = ix2 + mn
      v1 <- readArray a i
      v2 <- readArray a j
      writeArray a j v1
      writeArray a i v2

    {-# INLINE extract #-}
    extract = extractRoot (getN - 1)
      where
        extractRoot k | k <= 0    = return ()
                      | otherwise = do
            exch k 0
            downHeap k 0
            extractRoot (k - 1)

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

insertsortLimit :: Int
insertsortLimit = 32

depthCoeficient :: Double
depthCoeficient = 2 / log 2

{-# INLINE qsort #-}
qsort :: (MArray a e m, Ord e) => a Int e -> m ()
qsort = introsort' (return ()) ( -1 )

{-# INLINE maxQSortDepth #-}
maxQSortDepth :: (MArray a e m) => a Int e -> m Int
maxQSortDepth arr = do
    (mn, mx) <- getBounds arr
    return $ ceiling (depthCoeficient * log (fromIntegral $ mx - mn + 1))

{-# INLINE introsort #-}
introsort :: (MArray a e m, Ord e) => a Int e -> m ()
introsort arr = maxQSortDepth arr >>= \d -> introsort' (return ()) d arr

{-# INLINE introsort' #-}
introsort' :: (MArray a e m, Ord e) => m () -> Int -> a Int e -> m ()
introsort' cmpaction maxdepth a = getBounds a >>= uncurry (srt maxdepth)
  where
    srt depthleft mn mx
        | depthleft == 0             = heapsort' a mn mx
        | mn + insertsortLimit > mx  = insertsort' cmpaction a mn mx
        | otherwise = do
                -- Select a pivot - median of 3:
                pL <- readArray a mn
                pR <- readArray a mx
                let d = (mn + mx) `div` 2
                pD <- readArray a d
                cmpaction
                let (_, pidx) = median3 (pR, mx) (pD, d) (pL, mn)

                p <- swap d mn
                i <- split p (mn + 1) mx
                swap i mn

                let depthleft' = depthleft - 1
                -- Sort the smaller part first. Hopefully, tail
                -- recursion will catch on the larger part and so we'll
                -- have guaranteed that even in the worst case, we'll
                -- have at most (log n) calls on the stack.
                if i < d then do
                    srt depthleft' mn (i - 1)
                    srt depthleft' (i + 1) mx
                 else do
                    srt depthleft' (i + 1) mx
                    srt depthleft' mn (i - 1)
      where
        {-# INLINE swap #-}
        swap i j = do
            u <- readArray a i
            when (i /= j) $ do
                v <- readArray a j
                writeArray a i v
                writeArray a j u
            return u
        {-# INLINE split #-}
        split p = split'
          where
            split' i j = do
              i' <- moveRight i
              j' <- moveLeft j
              if i' < j'
                then swap i' j' >> split' (i' + 1) (j' - 1)
                else return j'
              where
                moveRight i | i > j = return i
                            | otherwise = do
                    v <- readArray a i
                    cmpaction
                    if v >= p
                        then return i
                        else moveRight (i + 1)
                moveLeft j | i > j = return j
                           | otherwise = do
                    v <- readArray a j
                    cmpaction
                    if v <= p
                        then return j
                        else moveLeft (j - 1)

{-# INLINE median3 #-}
median3 :: Ord a => a -> a -> a -> a
median3 a b c
    | a > b     = sel a b
    | otherwise = sel b a
  where
    sel l s | c > l     = l
            | c < s     = s
            | otherwise = c

-- ---------------------------
bigPrime = 10^(9::Int)+7 :: Int

newtype Modular = M { unModular :: Int }
  deriving (Show)

instance Num Modular where
  fromInteger x = M $ mod (fromInteger x) bigPrime
  (M x) + (M y) = M $ mod (x+y) bigPrime
  (M x) * (M y) = M $ mod (x*y) bigPrime
  (M x) - (M y) = M $ mod (x-y) bigPrime
  abs = undefined
  signum = undefined

readInt :: IO Int
readInt = do line <- BS.getLine
             let Just (n,_) = BS.readInt line
             return n

parseInts :: Int -> ByteString -> [Int]
parseInts k bs | k <= 0 = []
parseInts k bs = case BS.readInt (BS.dropWhile isSpace bs) of
                   Nothing -> []
                   Just (n,bs') -> n : parseInts (k-1) bs'

{-
  c[1] = 1
  c[ y ] = sum [ c[x] | (s,t) <- buses, t == y, (s',x) <- buses, x in [s,t-1] ]
  (1,2) (2,100) (100,200)
-}

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

inc arr i b = do v <- readArray arr i; writeArray arr i (v+b)

showArray label arr = do
  let (lo,hi) = bounds arr
  putStr $ label ++ ": "
  forM_ [lo..hi] $ \i -> do putStr $ printf "%3d " (arr!i)
  putStrLn ""

showTime start label = do
  now <- getCurrentTime
  let diff = diffUTCTime now start
  putStrLn $ label ++ ": " ++ show diff

solve n 0 = return 0
solve n m = do
  -- start <- getCurrentTime
  let mark label = return () -- showTime start label
  arr <- newArray (0,m-1) (0,0) :: IO (IOArray Int (Int,Int))
  forM_ [0..m-1] $ \i -> do
    (a:b:_) <- fmap (parseInts 2) BS.getLine
    writeArray arr i (b,a)
  mark "read buses"

  qsort arr
  arr <- M.freeze arr :: IO (Array Int (Int,Int))

  -- putStrLn $ show $ arr ! (m-1)
  mark "sorted"

  barr <- newArray (0,m) 0 :: IO (IOUArray Int Int)
  carr <- newArray (0,m) 0 :: IO (IOUArray Int Int)
  mark "newArray"

  let getFst i = fst $ arr!i
      getSnd i = snd $ arr!i

  writeArray barr 1 (getFst 0)
  writeArray carr 0 1
  let eloop e i | i >= m = return e
      eloop e i = do
        if getFst i /= getFst (i-1)
          then do let e' = e+1
                  writeArray barr e' (getFst i)
                  writeArray carr i e'
                  eloop e' (i+1)
          else do writeArray carr i e; eloop e (i+1)

  elast <- eloop 1 1
  mark "eloop"

  barr <- M.freeze barr :: IO (UArray Int Int)
  carr <- M.freeze carr :: IO (UArray Int Int)
  mark "freezes"

  if barr!elast /= n
    then do return 0
    else do farr <- newArray (0,m) 0 :: IO (IOUArray Int Int)
            sarr <- newArray (0,m) 0 :: IO (IOUArray Int Int)
            writeArray farr 0 1
            writeArray sarr 0 1

            forM_ [0..m-1] $ \i -> do
              let binsearch left right | left < right =
                    let h = div (left+right) 2
                    in if (barr!h) < getSnd i then binsearch (h+1) right
                                              else binsearch left h
                  binsearch left right = right
              let r = binsearch 0 (carr!i)
              let k = carr!i
              when (r < k) $ do
                s1 <- readArray sarr (k-1)
                s2 <- if r > 0 then readArray sarr (r-1) else return 0
                v <- readArray farr k
                writeArray farr k (mod (v+s1-s2) bigPrime)
              when (k /= carr!(i+1)) $ do
                a <- readArray sarr (k-1)
                b <- readArray farr k
                writeArray sarr k (mod (a+b) bigPrime)
            answer <- readArray farr elast
            return answer

main = do
  (n:m:_) <- getIntList
  answer <- solve n m
  print answer

import Control.Monad
import Data.Array
import Data.List
import Data.Ord
import qualified Data.IntMap.Strict as M
import Debug.Trace

{-
  c[1] = 1
  c[ y ] = sum [ c[x] | (s,t) <- buses, t == y, (s',x) <- buses, x in [s,t-1] ]
  (1,2) (2,100) (100,200)
-}

-- find the first index i in [a,b) where pred (arr!i) is True
lowerBound arr a b pred = go a (b-a)
  where go a count =
          if count > 0
            then let mid = a + step
                     step = div count 2
                 in if pred (arr!mid) then go a step
                                      else go (mid+1) (count-step-1)
            else a

inc :: Int -> M.IntMap Int -> Int -> M.IntMap Int
inc k m by = M.insert k v m
  where v = mod (by + M.findWithDefault 0 k m) bigPrime

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

bigPrime = 10^9+7 :: Int

sum' xs = foldl' (\s x -> mod (s+x) bigPrime) 0 xs

main = do
  (n:m:_) <- getIntList
  buses <- fmap ([(0,0)] ++) $ replicateM m $ do (a:b:_) <- getIntList; return (a,b)
  let byEnd = sortBy (comparing snd) buses
      arr = listArray (1,m) byEnd :: Array Int (Int,Int)
      loop cnts (s,t) =
        let i = lowerBound arr 1 (m+1) (\(s',t') -> s <= t')
            bs = filter (\b -> snd b < t) [ arr!k | k <- [i..m] ]
              where hoo x = trace msg x
                      where msg = "--- buses for " ++ show (s,t) ++ " = " ++ show x
            cs = [ M.findWithDefault 0 t' cnts | (_,t') <- bs ]
            cnts' = inc t cnts (sum' cs)
        in cnts'
      cnts = foldl' loop (M.insert 0 1 M.empty) byEnd
      answer = M.findWithDefault 0 n cnts
  print answer

import Control.Monad
import Data.Array
import Data.List
import Data.Ord
import qualified Data.IntMap.Strict as M
import Debug.Trace

{-
  c[1] = 1
  c[ y ] = sum [ c[x] | (s,t) <- buses, t == y, (s',x) <- buses, x in [s,t-1] ]
  (1,2) (2,100) (100,200)
-}

-- find the first index i in [a,b) where pred (arr!i) is True
lowerBound arr a b pred = go a (b-a)
  where go a count =
          if count > 0
            then let mid = a + step
                     step = div count 2
                 in if pred (arr!mid) then go a step
                                      else go (mid+1) (count-step-1)
            else a

inc :: Int -> M.IntMap Int -> Int -> M.IntMap Int
inc k m by = M.insert k v m
  where v = mod (by + M.findWithDefault 0 k m) bigPrime

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

bigPrime = 10^9+7 :: Int

sum' xs = foldl' (\s x -> mod (s+x) bigPrime) 0 xs

main = do
  (n:m:_) <- getIntList
  buses <- fmap ([(0,0)] ++) $ replicateM m $ do (a:b:_) <- getIntList; return (a,b)
  let byEnd = sortBy (comparing snd) buses
      arr = listArray (1,m) byEnd :: Array Int (Int,Int)
      loop cnts (s,t) =
        let cs = [ M.findWithDefault 0 t' cnts | (_,t') <- buses, s <= t' && t' < t ]
            cnts' = inc t cnts (sum' cs)
        in cnts'
      cnts = foldl' loop (M.insert 0 1 M.empty) byEnd
      answer = M.findWithDefault 0 n cnts
  print answer

import Control.Monad
import Data.Array
import Data.List
import Data.Ord
import qualified Data.IntMap.Strict as M
import Debug.Trace

{-
  c[1] = 1
  c[ y ] = sum [ c[x] | (s,t) <- buses, t == y, (s',x) <- buses, x in [s,t-1] ]
  (1,2) (2,100) (100,200)
-}

-- find the first index i in [a,b) where pred (arr!i) is True
lowerBound arr a b pred = go a (b-a)
  where go a count =
          if count > 0
            then let mid = a + step
                     step = div count 2
                 in if pred (arr!mid) then go a step
                                      else go (mid+1) (count-step-1)
            else a

inc :: Int -> M.IntMap Int -> Int -> M.IntMap Int
inc k m by = M.insert k v m
  where v = by + M.findWithDefault 0 k m

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

main = do
  (n:m:_) <- getIntList
  buses <- fmap ([(0,0)] ++) $ replicateM m $ do (a:b:_) <- getIntList; return (a,b)
  let byEnd = sortBy (comparing snd) buses
      arr = listArray (1,m) byEnd :: Array Int (Int,Int)
      loop cnts (s,t) =
        let i = lowerBound arr 1 (m+1) (\(s',t') -> s <= t')
            bs = filter (\b -> snd b < t) [ arr!k | k <- [i..m] ]
              where hoo x = trace msg x
                      where msg = "--- buses for " ++ show (s,t) ++ " = " ++ show x
            cs = [ M.findWithDefault 0 t' cnts | (_,t') <- bs ]
            cnts' = inc t cnts (sum cs)
        in cnts'
      cnts = foldl' loop (M.insert 0 1 M.empty) byEnd
      answer = M.findWithDefault 0 n cnts
  print answer

import Control.Monad
import Data.Array
import Data.List
import Data.Ord
import qualified Data.IntMap.Strict as M
import Debug.Trace

{-
  c[1] = 1
  c[ y ] = sum [ c[x] | (s,t) <- buses, t == y, (s',x) <- buses, x in [s,t-1] ]
  (1,2) (2,100) (100,200)
-}

-- find the first index i in [a,b) where pred (arr!i) is True
lowerBound arr a b pred = go a (b-a)
  where go a count =
          if count > 0
            then let mid = a + step
                     step = div count 2
                 in if pred (arr!mid) then go a step
                                      else go (mid+1) (count-step-1)
            else a

inc :: Int -> M.IntMap Int -> Int -> M.IntMap Int
inc k m by = M.insert k v m
  where v = mod (by + M.findWithDefault 0 k m) bigPrime

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

bigPrime = 10^9+7 :: Int

main = do
  (n:m:_) <- getIntList
  buses <- fmap ([(0,0)] ++) $ replicateM m $ do (a:b:_) <- getIntList; return (a,b)
  let byEnd = sortBy (comparing snd) buses
      arr = listArray (1,m) byEnd :: Array Int (Int,Int)
      loop cnts (s,t) =
        let i = lowerBound arr 1 (m+1) (\(s',t') -> s <= t')
            bs = filter (\b -> snd b < t) [ arr!k | k <- [i..m] ]
              where hoo x = trace msg x
                      where msg = "--- buses for " ++ show (s,t) ++ " = " ++ show x
            cs = [ M.findWithDefault 0 t' cnts | (_,t') <- bs ]
            cnts' = inc t cnts (sum cs)
        in cnts'
      cnts = foldl' loop (M.insert 0 1 M.empty) byEnd
      answer = M.findWithDefault 0 n cnts
  print answer


In Disgaea as in most role-playing games, characters have skills that determine the character's ability to use certain weapons or spells. If the character does not have the necessary skill, he cannot use it. The skill level is represented as an integer that increases when you use this skill. Different character classes are characterized by different skills. Unfortunately, the skills that are uncommon for the given character's class are quite difficult to obtain. To avoid this limitation, there is the so-called transmigration. Transmigration is reincarnation of the character in a new creature. His soul shifts to a new body and retains part of his experience from the previous life. As a result of transmigration the new character gets all the skills of the old character and the skill levels are reduced according to the k coefficient (if the skill level was equal to x, then after transmigration it becomes equal to [kx], where [y] is the integral part of y). If some skill's levels are strictly less than 100, these skills are forgotten (the character does not have them any more). After that the new character also gains the skills that are specific for his class, but are new to him. The levels of those additional skills are set to 0. Thus, one can create a character with skills specific for completely different character classes via transmigrations. For example, creating a mage archer or a thief warrior is possible. You are suggested to solve the following problem: what skills will the character have after transmigration and what will the levels of those skills be?

The first line contains three numbers n, m and k — the number of skills the current character has, the number of skills specific for the class into which the character is going to transmigrate and the reducing coefficient respectively; n and m are integers, and k is a real number with exactly two digits after decimal point (1 ≤ n, m ≤ 20, 0.01 ≤ k ≤ 0.99). Then follow n lines, each of which describes a character's skill in the form "name exp" — the skill's name and the character's skill level: name is a string and exp is an integer in range from 0 to 9999, inclusive.  Then follow m lines each of which contains names of skills specific for the class, into which the character transmigrates.  All names consist of lowercase Latin letters and their lengths can range from 1 to 20 characters, inclusive. All character's skills have distinct names. Besides the skills specific for the class into which the player transmigrates also have distinct names.

Print on the first line number z — the number of skills the character will have after the transmigration. Then print z lines, on each of which print a skill's name and level, separated by a single space. The skills should be given in the lexicographical order.

5 4 0.75
axe 350
impaler 300
ionize 80
megafire 120
magicboost 220
heal
megafire
shield
magicboost

6
axe 262
heal 0
impaler 225
magicboost 165
megafire 0
shield 0

module Main where

import Control.Monad
import qualified Data.Map as Map
import qualified Data.Set as Set

main = do
    inputNMK <- words `liftM` getLine
    let n = read $ inputNMK !! 0 :: Int
        m = read $ inputNMK !! 1 :: Int
        k = read $ inputNMK !! 2 :: Double

    skill <- foldM (\skill _ -> do
        inputSkill <- words `liftM` getLine
        let name = head inputSkill
            level = read $ inputSkill !! 1 :: Int
        return $ Map.insert name level skill
        ) Map.empty [1..n]

    (skill', new_skill') <- foldM (\(skill, new_skill) _ -> do
        name <- getLine
        return $ (Map.insertWith (\new old ->
            let level = floor $ fromIntegral old * k + 0.00001 :: Int in
            if level < 100
                then 0
                else level
            ) name 0 skill, Set.insert name new_skill)
        ) (skill, Set.empty) [1..m]

    --putStrLn $ show skill
    --putStrLn $ show skill'
    --putStrLn $ show new_skill'

    let res = map (\(k, v) -> k ++ " " ++ show v) $ Map.toList $ Map.filter ( >= 0 ) $ Map.mapWithKey (\name level ->
            if Set.member name new_skill'
            then level
            else let level' = floor $ fromIntegral level * k + 0.00001 :: Int in
            if level' < 100
                then -1
                else level'
            ) skill'
    putStrLn $ show $ length res
    putStr $ unlines res

import List (sortBy)
import Monad (liftM)
import Prelude hiding (reads)

readPair :: String -> (String, Int)
readPair line  =  case words line of
    [a, b]  ->  (a, read b)

readTriple :: String -> (Int, Int, Int)
readTriple line  =  case words line of
    [a, b, c]  ->  (read a, read b, read $ drop 2 c)

solve :: Int -> [(String, Int)] -> [String] -> [(String, Int)]
solve k before after  =  sortBy (\a b -> compare (fst a) (fst b)) answer
  where
    filtered  =  filter ((> 99) . snd) $ mapP id (flip div 100 . (*k)) before
    answer  =  foldl add filtered after
    add ss s
      | elem s (map fst ss)  =  ss
      | otherwise  =  (s, 0) : ss

mapP :: (a -> c) -> (b -> d) -> [(a, b)] -> [(c, d)]
mapP f1 f2 xs  =  map (\(a, b) -> (f1 a, f2 b)) xs

main :: IO ()
main  =  do
    (n, m, k)  <-  liftM readTriple getLine
    lines'  <-  liftM lines getContents
    let before  =  (map readPair . take n) lines'
    let after   =  (take m . drop n) lines'
    let answer  =  solve k before after
    print $ length answer
    mapM_ putStrLn $ map (\(s, x) -> s ++ " " ++ show x) answer

{-# LANGUAGE TypeSynonymInstances #-}
import Data.List
class Scan a where scan' :: String -> a
instance Scan Int where scan' n = read n
instance Scan Char where scan' (x:_) = x
instance Scan Float where scan' f = read f
instance Scan Double where scan' d = read d
instance Scan Integer where scan' n = read n
instance Scan String where scan' x = x
instance (Scan a,Scan b) => Scan (a,b) where scan' x = scan'' (words x)
                                                 where
                                                   scan'' (x:y:_) = (scan' x,scan' y)
instance (Scan a,Scan b,Scan c) => Scan (a,b,c) where scan' x = scan'' (words x)
                                                          where
                                                            scan'' (x:y:z:_) = (scan' x,scan' y,scan' z)
instance (Scan a,Scan b,Scan c,Scan d) => Scan (a,b,c,d) where scan' x = scan'' (words x)
                                                                   where
                                                                     scan'' (w:x:y:z:_) = (scan' w,scan' x,scan' y,scan' z)
instance (Scan a,Scan b,Scan c,Scan d,Scan e) => Scan (a,b,c,d,e) where scan' x = scan'' (words x)
                                                                            where
                                                                              scan'' (v:w:x:y:z:_) = (scan' v,scan' w,scan' x,scan' y,scan' z)
class Ans a where showans :: a -> String
instance Ans Int where showans x = show x
instance Ans Char where showans x = [x]
instance Ans Float where showans x = show x
instance Ans Double where showans x = show x
instance Ans Integer where showans x = show x
instance Ans String where showans x = x
instance (Ans a, Ans b) => Ans (a,b) where
    showans (x,y) = showans x ++ " " ++ showans y
instance (Ans a, Ans b,Ans c) => Ans (a,b,c) where
    showans (x,y,z) = showans x ++ " " ++ showans y ++ " " ++ showans z

scan :: (Scan a) => IO a
scan = do n <- getLine
          return (scan' n)

scans :: (Scan a) => Int -> IO [a]
scans 0 = return []
scans n = do x <- scan
             xs <- scans (n-1)
             return (x:xs)

putAnsLn :: (Ans a) => a -> IO ()
putAnsLn ans = putStrLn (showans ans)

putAnsLns :: (Ans a) => [a] -> IO ()
putAnsLns (x:xs) = do putAnsLn x
                      putAnsLns xs
putAnsLns [] = return ()

putDebugLn :: (Show a) => a -> IO ()
putDebugLn ans = putStrLn (show ans)

notinc [] _ = True
notinc ((a,_):l) (x,y) = if x==a then False else notinc l (x,y)

solve :: Int -> Int -> Double -> [(String,Int)] -> [String] -> [(String,Int)]
solve n m k old new = sort (old' ++ new')
    where
      old' = filter (\(n,e) -> e>=100) (map (\(n,e) -> (n,floor ((fromIntegral e)*k+0.000001))) old)
      new' = filter (notinc old') [(i,0)|i<-new]

sub n m k old new = let answer = (solve n m k old new)
                    in
                      do putAnsLn (length answer)
                         putAnsLns answer

main = do (n,m,k) <- scan::IO (Int,Int,Double)
          old <- scans n::IO [(String,Int)]
          new <- scans m::IO [String]
          sub n m k old new

import List
q[s,e]=(s,read e)
c(a,_)(b,_)=compare a b
s([n,_,k]:t)=sortBy c$h++map z(filter(`notElem`map fst h)w)where{(g,v)=splitAt(read n)t;w=map(!!0)v;h=map q g>>=j;j(s,e)|x<100=[]|1>0=[(s,x)]where x=e*read(drop 2 k)`div`100}
r(a,b)=a++" "++show b
p l=show(length l):map r l
z x=(x,0)
main=interact$unlines.p.s.map words.lines

import List
s([n,_,k]:t)=sort$h++[(x,0)|x<-map(!!0)v,x`notElem`map fst h]where{(g,v)=splitAt(read n)t;h=g>>=j;j[s,e]|x>99=[(s,x)]|1>0=[]where x=(read e)*read(drop 2 k)`div`100}
p l=show(length l):[a++" "++show b|(a,b)<-l]
main=interact$unlines.p.s.map words.lines

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Data.Ord
import Control.Applicative
import Control.Monad
import qualified Data.Map as Map
import Data.Map(Map)
import Data.List

parseSkill [skill, exp] = (skill, read exp)

parseRational :: String -> Rational
parseRational = pr . span (/= '.')
  where
    pr (n, "") = fromIntegral (read n)
    pr (a, bb) = fromIntegral (read a) + fromIntegral (read b) / 10 ^ length b
      where
        b = tail bb

main = do
  [read -> (n :: Integer), read -> (m :: Integer), parseRational -> k] <- words <$> getLine
  have <- replicateM (fromInteger n) (parseSkill . words <$> getLine)
  want <- replicateM (fromInteger m) getLine
  let
    r :: (String, Integer) -> [(String, Integer)]
    r (s, e)
      | e' < 100 = []
      | otherwise = [(s, e')]
      where
        e' = floor (fromInteger e * k)
    have' = have >>= r
    have'' = have' ++ map (\s -> (s, 0)) (filter (`notElem` map fst have') want)
    pr (s, e) = putStrLn (s ++ " " ++ show e)

  putStrLn (show $ length have'')
  mapM pr (sortBy (comparing fst) have'')

-- Problem "A" Transmigration --

import Data.List
import Data.Ratio

data Skill = Skill String Int

instance Eq Skill where
  (Skill lhs _) == (Skill rhs _) = lhs == rhs

instance Ord Skill where
  (Skill lhs _) <= (Skill rhs _) = lhs <= rhs

instance Show Skill where
  show (Skill name level) = name ++ " " ++ (show level)

fromPair :: (String, Int) -> Skill
fromPair (name, level) = Skill name level

readRationalEps = 0.0001
skillMinimumLevel = 100

readInt :: String -> Int
readInt token = read token :: Int

readDouble :: String -> Double
readDouble token = read token :: Double

readRational :: String -> Rational
readRational token = approxRational (readDouble token) readRationalEps

stride :: Int -> [a] -> [a]
stride _ []     = []
stride n (x:xs) = x : stride n (drop (n - 1) xs)

scaleSkills :: Rational -> [Skill] -> [Skill]
scaleSkills k = filter validSkill . map scaleSkill
  where validSkill (Skill _ level) = level >= skillMinimumLevel
        scaleSkill (Skill name level) = Skill name
                                              (floor $ k * (toRational level))

solve :: (Rational, [Skill], [Skill]) -> [Skill]
solve (k, rold, rnew) = sort $ old ++ new
  where old = scaleSkills k rold
        new = filter (\s -> notElem s old) rnew

prepareInput :: [String] -> (Rational, [Skill], [Skill])
prepareInput (sn:sm:sk:skills) = (k,
                                  map fromPair $
                                  zip oldSkillNames oldSkillLevels,
                                  map fromPair $
                                  zip newSkillNames newSkillLevels)
  where n = readInt sn
        m = readInt sm
        k = readRational sk
        oldSkillNames = stride 2 $ take (2 * n) skills
        oldSkillLevels = map readInt $ stride 2 $ tail $ take (2 * n) skills
        newSkillNames = drop (2 * n) skills
        newSkillLevels = repeat 0

prepareOutput :: [Skill] -> String
prepareOutput skills = unlines $ [show $ length skills] ++ (map show skills)

main :: IO ()
main = interact (prepareOutput . solve . prepareInput . words)

{-# LANGUAGE TypeSynonymInstances #-}
import Data.List
class Scan a where scan' :: String -> a
instance Scan Int where scan' n = read n
instance Scan Char where scan' (x:_) = x
instance Scan Float where scan' f = read f
instance Scan Double where scan' d = read d
instance Scan Integer where scan' n = read n
instance Scan String where scan' x = x
instance (Scan a,Scan b) => Scan (a,b) where scan' x = scan'' (words x)
                                                 where
                                                   scan'' (x:y:_) = (scan' x,scan' y)
instance (Scan a,Scan b,Scan c) => Scan (a,b,c) where scan' x = scan'' (words x)
                                                          where
                                                            scan'' (x:y:z:_) = (scan' x,scan' y,scan' z)
instance (Scan a,Scan b,Scan c,Scan d) => Scan (a,b,c,d) where scan' x = scan'' (words x)
                                                                   where
                                                                     scan'' (w:x:y:z:_) = (scan' w,scan' x,scan' y,scan' z)
instance (Scan a,Scan b,Scan c,Scan d,Scan e) => Scan (a,b,c,d,e) where scan' x = scan'' (words x)
                                                                            where
                                                                              scan'' (v:w:x:y:z:_) = (scan' v,scan' w,scan' x,scan' y,scan' z)
class Ans a where showans :: a -> String
instance Ans Int where showans x = show x
instance Ans Char where showans x = [x]
instance Ans Float where showans x = show x
instance Ans Double where showans x = show x
instance Ans Integer where showans x = show x
instance Ans String where showans x = x
instance (Ans a, Ans b) => Ans (a,b) where
    showans (x,y) = showans x ++ " " ++ showans y
instance (Ans a, Ans b,Ans c) => Ans (a,b,c) where
    showans (x,y,z) = showans x ++ " " ++ showans y ++ " " ++ showans z

scan :: (Scan a) => IO a
scan = do n <- getLine
          return (scan' n)

scans :: (Scan a) => Int -> IO [a]
scans 0 = return []
scans n = do x <- scan
             xs <- scans (n-1)
             return (x:xs)

putAnsLn :: (Ans a) => a -> IO ()
putAnsLn ans = putStrLn (showans ans)

putAnsLns :: (Ans a) => [a] -> IO ()
putAnsLns (x:xs) = do putAnsLn x
                      putAnsLns xs
putAnsLns [] = return ()

putDebugLn :: (Show a) => a -> IO ()
putDebugLn ans = putStrLn (show ans)

notinc [] _ = True
notinc ((a,_):l) (x,y) = if x==a then False else notinc l (x,y)

solve :: Int -> Int -> Double -> [(String,Int)] -> [String] -> [(String,Int)]
solve n m k old new = sort (old' ++ new')
    where
      old' = filter (\(n,e) -> e>100) (map (\(n,e) -> (n,floor ((fromIntegral e)*k+0.000001))) old)
      new' = filter (notinc old') [(i,0)|i<-new]

main = do (n,m,k) <- scan::IO (Int,Int,Double)
          old <- scans n::IO [(String,Int)]
          new <- scans m::IO [String]
          putAnsLns (solve n m k old new)

{-# LANGUAGE TypeSynonymInstances #-}
import Data.List
class Scan a where scan' :: String -> a
instance Scan Int where scan' n = read n
instance Scan Char where scan' (x:_) = x
instance Scan Float where scan' f = read f
instance Scan Double where scan' d = read d
instance Scan Integer where scan' n = read n
instance Scan String where scan' x = x
instance (Scan a,Scan b) => Scan (a,b) where scan' x = scan'' (words x)
                                                 where
                                                   scan'' (x:y:_) = (scan' x,scan' y)
instance (Scan a,Scan b,Scan c) => Scan (a,b,c) where scan' x = scan'' (words x)
                                                          where
                                                            scan'' (x:y:z:_) = (scan' x,scan' y,scan' z)
instance (Scan a,Scan b,Scan c,Scan d) => Scan (a,b,c,d) where scan' x = scan'' (words x)
                                                                   where
                                                                     scan'' (w:x:y:z:_) = (scan' w,scan' x,scan' y,scan' z)
instance (Scan a,Scan b,Scan c,Scan d,Scan e) => Scan (a,b,c,d,e) where scan' x = scan'' (words x)
                                                                            where
                                                                              scan'' (v:w:x:y:z:_) = (scan' v,scan' w,scan' x,scan' y,scan' z)
class Ans a where showans :: a -> String
instance Ans Int where showans x = show x
instance Ans Char where showans x = [x]
instance Ans Float where showans x = show x
instance Ans Double where showans x = show x
instance Ans Integer where showans x = show x
instance Ans String where showans x = x
instance (Ans a, Ans b) => Ans (a,b) where
    showans (x,y) = showans x ++ " " ++ showans y
instance (Ans a, Ans b,Ans c) => Ans (a,b,c) where
    showans (x,y,z) = showans x ++ " " ++ showans y ++ " " ++ showans z

scan :: (Scan a) => IO a
scan = do n <- getLine
          return (scan' n)

scans :: (Scan a) => Int -> IO [a]
scans 0 = return []
scans n = do x <- scan
             xs <- scans (n-1)
             return (x:xs)

putAnsLn :: (Ans a) => a -> IO ()
putAnsLn ans = putStrLn (showans ans)

putAnsLns :: (Ans a) => [a] -> IO ()
putAnsLns (x:xs) = do putAnsLn x
                      putAnsLns xs
putAnsLns [] = return ()

putDebugLn :: (Show a) => a -> IO ()
putDebugLn ans = putStrLn (show ans)

notinc [] _ = True
notinc ((a,_):l) (x,y) = if x==a then False else notinc l (x,y)

solve :: Int -> Int -> Double -> [(String,Int)] -> [String] -> [(String,Int)]
solve n m k old new = sort (old' ++ new')
    where
      old' = filter (\(n,e) -> e>100) (map (\(n,e) -> (n,floor ((fromIntegral e)*k+0.000001))) old)
      new' = filter (notinc old') [(i,0)|i<-new]

sub n m k old new = let answer = (solve n m k old new)
                    in
                      do putAnsLn (length answer)
                         putAnsLns answer

main = do (n,m,k) <- scan::IO (Int,Int,Double)
          old <- scans n::IO [(String,Int)]
          new <- scans m::IO [String]
          sub n m k old new

import IO
import List

putAnsLn :: (Show a) => a -> IO ()
putAnsLn ans = putStrLn (show ans)

getPairs :: IO (String,Int)
getPairs = do ns <- getLine
              return (conv (make_pair [n|n<-(words ns)]))
                  where
                    conv (x,y) = (x,read y::Int)
                    make_pair (x:y:_) = (x,y)
                    make_pair _ = ("0","0")

getPairLines :: Int -> IO [(String,Int)]
getPairLines n = if n > 0 then
                     do l <- getPairs
                        ls <- getPairLines (n-1)
                        return (l:ls)
                 else
                     return []

getStatus :: IO (Int, Int, Float)
getStatus = do l <- getLine
               return (conv [x|x<-(words l)])
                   where
                     conv (x:y:z:_) = (read x::Int ,read y::Int,read z::Float)

getLines :: Int -> IO [String]
getLines n = if n > 0 then
                 do l <- getLine
                    ls <- getLines (n-1)
                    return (l:ls)
             else
                 return []

include [] e = False
include ((x,_):xs) e = if x==e then True else include xs e

toStr str [] = str
toStr str ((x,exp):xs) = toStr ((x ++ " " ++ (show exp)):str) xs

solve :: Float -> Int -> [(String,Int)] -> [String] -> [String]
solve k m skills newskills = mpair (sort (toStr [] (merge (trans [] skills) newskills)))
    where
      trans l [] = l
      trans l ((sk,exp):sks) = let new_exp = (floor ((fromIntegral exp) * k)) in if new_exp < 100 then trans l sks else trans ((sk,new_exp):l) sks
      merge l [] = l
      merge l (x:xs) = if include l x then merge l xs else merge ((x,0):l) xs
      mpair l = (show (length l)):l

putAnsLns [] = putStr ""
putAnsLns (x:xs) = do putStrLn x
                      putAnsLns xs

main = do (n, m, k) <- getStatus
          skills <- getPairLines n
          newskills <- getLines m
          putAnsLns (solve k m skills newskills)

q[s,e]=(s,read e)
s([n,_,k]:t)=h++map z(filter(`notElem`map fst h)w)where{(g,v)=splitAt(read n)t;w=map(!!0)v;h=map q g>>=j;j(s,e)|x<100=[]|1>0=[(s,x)]where x=e*read(drop 2 k)`div`100}
r(a,b)=a++" "++show b
p l=show(length l):map r l
z x=(x,0)
main=interact$unlines.p.s.map words.lines

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Data.Ord
import Control.Applicative
import Control.Monad
import qualified Data.Map as Map
import Data.Map(Map)
import Data.List

parseSkill [skill, exp] = (skill, read exp)

main = do
  [read -> (n :: Integer), read -> (m :: Integer), read -> (k :: Double)] <- words <$> getLine
  have <- replicateM (fromInteger n) (parseSkill . words <$> getLine)
  want <- replicateM (fromInteger m) getLine
  let
    r (s, e)
      | e' < 100 = []
      | otherwise = [(s, e')]
      where
        e' = floor (fromIntegral e * k)
    have' = have >>= r
    have'' = have' ++ map (\s -> (s, 0)) (filter (`notElem` map fst have') want)
    pr (s, e) = putStrLn (s ++ " " ++ show e)

  putStrLn (show $ length have'')
  mapM pr (sortBy (comparing fst) have'')

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Data.Ord
import Control.Applicative
import Control.Monad
import qualified Data.Map as Map
import Data.Map(Map)
import Data.List

parseSkill [skill, exp] = (skill, read exp)

main = do
  [read -> (n :: Integer), read -> (m :: Integer), read -> (k :: Double)] <- words <$> getLine
  have <- replicateM (fromInteger n) (parseSkill . words <$> getLine)
  want <- replicateM (fromInteger m) getLine
  let
    r (s, e)
      | e' < 100 = []
      | otherwise = [(s, e')]
      where
        e' = floor (fromIntegral e * k)
    have' = have >>= r
    have'' = have' ++ map (\s -> (s, 0)) (filter (`notElem` map fst have') want)
    pr (s, e) = putStrLn (s ++ " " ++ show e)

  mapM pr (sortBy (comparing fst) have'')


Nezzar loves the game osu!.osu! is played on beatmaps, which can be seen as an array consisting of distinct points on a plane. A beatmap is called nice if for any three consecutive points $$$A,B,C$$$ listed in order, the angle between these three points, centered at $$$B$$$, is strictly less than $$$90$$$ degrees.  Points $$$A,B,C$$$ on the left have angle less than $$$90$$$ degrees, so they can be three consecutive points of a nice beatmap; Points $$$A',B',C'$$$ on the right have angle greater or equal to $$$90$$$ degrees, so they cannot be three consecutive points of a nice beatmap. Now Nezzar has a beatmap of $$$n$$$ distinct points $$$A_1,A_2,\ldots,A_n$$$. Nezzar would like to reorder these $$$n$$$ points so that the resulting beatmap is nice.Formally, you are required to find a permutation $$$p_1,p_2,\ldots,p_n$$$ of integers from $$$1$$$ to $$$n$$$, such that beatmap $$$A_{p_1},A_{p_2},\ldots,A_{p_n}$$$ is nice. If it is impossible, you should determine it.

The first line contains a single integer $$$n$$$ ($$$3 \le n \le 5000$$$). Then $$$n$$$ lines follow, $$$i$$$-th of them contains two integers $$$x_i$$$, $$$y_i$$$ ($$$-10^9 \le x_i, y_i \le 10^9$$$) — coordinates of point $$$A_i$$$. It is guaranteed that all points are distinct.

If there is no solution, print $$$-1$$$. Otherwise, print $$$n$$$ integers, representing a valid permutation $$$p$$$. If there are multiple possible answers, you can print any.

NoteHere is the illustration for the first test:  Please note that the angle between $$$A_1$$$, $$$A_2$$$ and $$$A_5$$$, centered at $$$A_2$$$, is treated as $$$0$$$ degrees. However, angle between $$$A_1$$$, $$$A_5$$$ and $$$A_2$$$, centered at $$$A_5$$$, is treated as $$$180$$$ degrees.

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class

import qualified Data.ByteString.Lazy.Char8 as P

import Data.List
import Data.Int
import Data.Ord

import Data.Array.IArray

type SIO = StateT P.ByteString IO

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

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

data Pt = Pt !Int !Int

dist :: Pt -> Pt -> Int64
dist (Pt x1 y1) (Pt x2 y2) = let
  [x1', y1', x2', y2'] = map fromIntegral [x1, y1, x2, y2]
  dx = x2' - x1'
  dy = y2' - y1'
  in  dx*dx + dy*dy

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [n] <- readInts
  pts <- replicateM n $ do
    [x, y] <- readInts
    pure $ Pt x y
  let
    ptArr :: Array Int Pt
    ptArr = listArray (1, n) pts
    step :: [Int] -> Maybe (Int, [Int])
    step [] = Nothing
    step [p] = Just (p, [])
    step (p:qs) = let
      ppt = ptArr ! p
      next = maximumBy (comparing $ \q -> dist ppt (ptArr ! q)) qs
      nqs = next : filter (/= next) qs
      in  Just (p, nqs)
    ans = unfoldr step [1..n]
    out = unwords [show k | k <- ans]
  lift . P.putStrLn $ P.pack out


Polycarpus is the director of a large corporation. There are n secretaries working for the corporation, each of them corresponds via the famous Spyke VoIP system during the day. We know that when two people call each other via Spyke, the Spyke network assigns a unique ID to this call, a positive integer session number.One day Polycarpus wondered which secretaries are talking via the Spyke and which are not. For each secretary, he wrote out either the session number of his call or a 0 if this secretary wasn't talking via Spyke at that moment.Help Polycarpus analyze these data and find out the number of pairs of secretaries that are talking. If Polycarpus has made a mistake in the data and the described situation could not have taken place, say so.Note that the secretaries can correspond via Spyke not only with each other, but also with the people from other places. Also, Spyke conferences aren't permitted — that is, one call connects exactly two people.

The first line contains integer n (1 ≤ n ≤ 103) — the number of secretaries in Polycarpus's corporation. The next line contains n space-separated integers: id1, id2, ..., idn (0 ≤ idi ≤ 109). Number idi equals the number of the call session of the i-th secretary, if the secretary is talking via Spyke, or zero otherwise. Consider the secretaries indexed from 1 to n in some way.

Print a single integer — the number of pairs of chatting secretaries, or -1 if Polycarpus's got a mistake in his records and the described situation could not have taken place.

NoteIn the first test sample there are two Spyke calls between secretaries: secretary 2 and secretary 4, secretary 3 and secretary 5.In the second test sample the described situation is impossible as conferences aren't allowed.

import Data.List (group, sort)

main = do
    getLine
    ids <- fmap (map read . words) getLine
    let calls = group $ sort $ filter (/=0) ids
    print $ if any ((>2) . length) calls
        then -1
        else length $ filter ((==2) . length) calls

{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, BangPatterns #-}

{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import Control.Monad
import Control.Monad.ST.Safe
import Control.Monad.State
import Data.Array
-- import Data.Array.IArray
import Data.Array.IO.Safe
import Data.Array.MArray.Safe
import Data.Array.ST.Safe
-- import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Builder as BB
import Data.Char
import Data.Function
-- import Data.Graph
import Data.Int
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
-- import Data.Tree
import Data.Tuple
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import System.IO
-- import Debug.Trace

-- getInts = fmap (map read . words) getLine
getInts = unfoldr (B.readInt . B.dropWhile isSpace) <$> B.getLine

main = do
  getLine
  as <- getInts

  let
    cs = map snd $ filter (\(x, _) -> x /= 0) $ map (\g -> (head g, length g)) $ group $ sort as

  print $ if any (> 2) cs
             then -1
             else length $ filter (== 2) cs

import Data.List

solve :: [Int] -> Int
solve = estimate . group . sort . filter (0/=)
  where estimate xs | any ((>2) . length) xs = -1
        estimate xs = length $ filter ((==2) . length) xs

main = interact $ show . solve . tail . map read . words

import Control.Monad (liftM)
import Data.Map.Strict (foldl', fromListWith)
import Prelude hiding (reads)

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

solve :: [Int] -> Int
solve  =  foldl' solve' 0 . fromListWith (+) . flip zip (repeat 1) . filter (/= 0)
  where
    solve' (-1) _  =  -1
    solve' x 1  =  x
    solve' x 2  =  x + 1
    solve' _ _  =  -1

main :: IO ()
main  =  getLine >> reads >>= print . solve

import Data.List
import Control.Applicative

main = do
    n <- getLine
    a <- map read <$> words <$> getLine
    let tmp = map length $ group $ sort $ filter (/= 0) a
    if all (<= 2) tmp
        then print $ length $ filter (== 2) tmp
        else print (- 1)

import Data.List (group, sort)

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

solve :: [Int] -> Int
solve = solve' . group . sort . map length . group . sort . filter (>0)

solve' :: [[Int]] -> Int
solve' xs | any ((>2) . head) xs = -1
          | otherwise = length $ last $ [] : filter ((==2) . head) xs

import Data.List (group, sort)

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

solve :: [Int] -> Int
solve = solve' . map length . group . sort . filter (>0)

solve' :: [Int] -> Int
solve' xs | any (>2) xs = -1
          | otherwise = length $ filter (==2) xs

import Data.List
main=interact$show.g.map length.group.sort.filter(>0).map read.tail.words
g x|any(>2)x= -1|1>0=length$filter(==2)x

import Data.List

clerkPairs :: (Integral a) => [a] -> a
clerkPairs ids = clerkPairs' 0 (group (sort (filter (/= 0) ids)))
  where clerkPairs' n [] = n
        clerkPairs' n (x:xs)
          | length x > 2 = -1
          | length x == 2 = clerkPairs' (n + 1) xs
          | otherwise = clerkPairs' n xs

main = do
  _ <- getLine
  idsInput <- getLine
  let ids = map (read :: String -> Integer) (words idsInput) in print (clerkPairs ids)

import Control.Applicative
import Data.List

main = do
  getLine
  ids <- map read.words <$> getLine
  print $ slv 0.group.sort $ filter (/= 0) ids

slv n [] = n
slv n (x:xs)
  | length x > 2 = -1
  | length x == 2 = slv (n+1) xs
  | otherwise = slv n xs

import Data.List
s l|any(>2)l= -1|1>0=length$filter(==2)l
main=interact$show.s.map length.group.sort.filter(>0).tail.map read.words

conv :: String -> [Int]
conv s = map read (words s)

find :: Int -> [Int] -> Int
find _ [] = 0
find cur (x:xs)
  | cur == x = 1 + find cur xs
  | otherwise = find cur xs

go :: [Int] -> Int
go [] = 0
go (x:xs) = (go ( xs )) + mod
  where cnt = find x xs
        mod
          | cnt == 1 = 1
          | cnt > 1 = - 1000
          | otherwise = 0

solve :: String -> String
solve input = show r
  where list = filter (\x -> x > 0) (drop 1 (conv input))
        ret = go list
        r = max (-1) ret

main = do
  interact solve

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

main :: IO ()
main = do
	_ <- getLine
	line <- getLine
	let
		arr = map length. group. filter (/= 0). sort. map (\x -> read x :: Integer). words $ line
		sol :: Int -> [Int] -> Int
		sol x [] = x
		sol x (p:ps)
		 | p > 2 = (-1)
		 | p == 2 = sol (x+1) ps
		 | otherwise = sol x ps
	print $ sol 0 arr

module Main where

import Data.List (group, sort)

solve :: [Int] -> Int
solve s | null incorrect = length pairs
        | otherwise      = -1
  where groups = map length . group . sort . filter (/= 0) $ s
        pairs = filter (== 2) groups
        incorrect = filter (> 2) groups

main = do
  numSessions <- getLine
  sessions <- fmap (map read . words) getLine
  putStrLn . show $ solve sessions

import Control.Applicative
import Data.List

main :: IO ()
main = do
  _ <- getLine
  a <- map length . group . sort . filter (/=(0::Int)) . map read . words <$> getLine
  print $ if maximum (0:a) > 2 then -1 else length $ filter (==2) a

import Data.Char(digitToInt)
import Data.List(sort)

toInt::[Char]->Int
toInt x =
 let
     toInt'::[Char]->Int->Int
     toInt' y z =
      if null y
         then z
         else toInt' (tail y) (z*10+(digitToInt (head y)-digitToInt '0'))
 in toInt' x 0

split::[Char]->[Char]->[[Char]]
split x y =
 let
  split'::[Char]->[Char]->[Char]->[[Char]]
  split' _ [] [] = []
  split' _ [] c = [c]
  split' a (b:bs) c =
   if null [t|t<-a,t==b]
   then split' a bs (b:c)
   else (reverse c):(split' a bs [])
 in split' x y []

getAns::[Int]->Int
getAns x =
 let
 getAns'::[Int]->Int->Int->Int->Int
 getAns' [] _ lstCnt ans =
  if lstCnt>2
   then -1
  else if lstCnt==2
   then ans+1
  else
   ans
 getAns' (x:xs) lst lstCnt ans =
  if x/=lst&&lstCnt>2
   then -1
  else if x/=lst&&lstCnt==2
   then getAns' xs x 1 (ans+1)
  else if x==lst
   then getAns' xs lst (lstCnt+1) ans
  else
   getAns' xs x 1 ans
 in getAns' x 0 0 0

main::IO()
main =
 do
 input <- getContents
 let
  numbers = fmap toInt (split " \n" input)
  n = head numbers
  id = sort [x|x<-(tail numbers),x/=0]
 print $ getAns id

import Data.List (group, sort)

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

solve :: [Int] -> Int
solve = solve' . group . sort . map length . group . sort

solve' :: [[Int]] -> Int
solve' xs | any ((>2) . head) xs = -1
          | otherwise = length $ last $ [] : filter ((==2) . head) xs

conv :: String -> [Int]
conv s = map read (words s)

find :: Int -> [Int] -> Int
find _ [] = 0
find cur (x:xs)
  | cur == x = 1 + find cur xs
  | otherwise = find cur xs

go :: Int -> [Int] -> Int
go _ [] = 0
go x xs = (go ( head xs ) ( tail xs )) + mod
  where cnt = find x xs
        mod
          | cnt == 1 = 1
          | cnt > 1 = - 1000
          | otherwise = 0

solve :: String -> String
solve input = show r
  where (x:xs) = drop 1 (conv input)
        ret = go x xs
        r = max (-1) ret

main = do
  interact solve

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

main :: IO ()
main = do
	_ <- getLine
	line <- getLine
	let
		arr = map fromIntegral.map length. group. filter (/= 0). sort. map (\x -> read x :: Integer). words $ line
		sol :: [Integer] -> Int
		sol [] = 0
		sol (p:ps)
		 | p > (2::Integer) = (-1)
		 | p == (2::Integer) = (1::Int) + sol ps
		 | p == (1::Integer) = sol ps
		 | otherwise = error "something wrong"
	print $ sol arr

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

main :: IO ()
main = do
	line <- getLine
	line2 <- getLine
	let
		n = read line ::Int
		arr = map length. group. filter (/= 0). sort. map (\x -> read x :: Int). words $ line2
		sol :: [Int] -> Int
		sol [] = 0
		sol (p:ps)
		 | p > 2 = (-1)
		 | p == 2 = 1 + sol ps
		 | otherwise = sol ps
	print $ sol arr

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

main :: IO ()
main = do
	_ <- getLine
	line <- getLine
	let
		arr = map length. group. filter (/= 0). sort. map (\x -> read x :: Integer). words $ line
		sol :: [Int] -> Int
		sol [] = 0::Int
		sol (p:ps)
		 | p > 2 = (-1)
		 | p == 2 = (1::Int) + sol ps
		 | p == 1 = sol ps
		 | otherwise = error "something wrong"
	print $ sol arr

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

main :: IO ()
main = do
	line <- getLine
	line2 <- getLine
	let
		n = read line ::Int
		arr = map length. group. sort. map (\x -> read x :: Int). words $ line2
		sol :: [Int] -> Int
		sol [] = 0
		sol (p:ps)
		 | p > 2 = (-1)
		 | p == 2 = 1 + sol ps
		 | otherwise = sol ps
	print $ sol arr

module Main where

import Data.List (group, sort)

solve :: [Int] -> Int
solve s | null incorrect = length pairs
        | otherwise      = -1
  where groups = map length . group $ sort s
        pairs = filter (== 2) groups
        incorrect = filter (> 2) groups

main = do
  numSessions <- getLine
  sessions <- fmap (map read . words) getLine
  putStrLn . show $ solve sessions

import Data.Char(digitToInt)
import Data.List(sort)

toInt::[Char]->Int
toInt x =
 let
     toInt'::[Char]->Int->Int
     toInt' y z =
      if null y
         then z
         else toInt' (tail y) (z*10+(digitToInt (head y)-digitToInt '0'))
 in toInt' x 0

split::[Char]->[Char]->[[Char]]
split x y =
 let
  split'::[Char]->[Char]->[Char]->[[Char]]
  split' _ [] [] = []
  split' _ [] c = [c]
  split' a (b:bs) c =
   if null [t|t<-a,t==b]
   then split' a bs (b:c)
   else (reverse c):(split' a bs [])
 in split' x y []

getAns::[Int]->Int
getAns x =
 let
 getAns'::[Int]->Int->Int->Int
 getAns' [] _ lstCnt =
  if lstCnt>2
   then -1
  else if lstCnt==2
   then 1
  else
   0
 getAns' (x:xs) lst lstCnt =
  if x/=lst&&lstCnt>2
   then -1
  else if x/=lst&&lstCnt==2
   then 1+(getAns' xs x 1)
  else if x==lst
   then getAns' xs lst (lstCnt+1)
  else
   getAns' xs x 1
 in getAns' x 0 0

main::IO()
main =
 do
 input <- getContents
 let
  numbers = fmap toInt (split " \n" input)
  n = head numbers
  id = sort [x|x<-(tail numbers),x/=0]
 print $ getAns id

import Data.Char(digitToInt)
import Data.List(sort)

toInt::[Char]->Int
toInt x =
 let
     toInt'::[Char]->Int->Int
     toInt' y z =
      if null y
         then z
         else toInt' (tail y) (z*10+(digitToInt (head y)-digitToInt '0'))
 in toInt' x 0

split::[Char]->[Char]->[[Char]]
split x y =
 let
  split'::[Char]->[Char]->[Char]->[[Char]]
  split' _ [] [] = []
  split' _ [] c = [c]
  split' a (b:bs) c =
   if null [t|t<-a,t==b]
   then split' a bs (b:c)
   else (reverse c):(split' a bs [])
 in split' x y []

getAns::[Int]->Int
getAns x =
 let
 getAns'::[Int]->Int->Int->Int->Int
 getAns' [] _ lstCnt ans =
  if lstCnt>2
   then -1
  else if lstCnt==2
   then ans+1
  else
   ans
 getAns' (x:xs) lst lstCnt ans =
  if x/=lst&&lstCnt>2
   then -1
  else if x/=lst&&lstCnt==2
   then getAns' xs lst lstCnt (ans+1)
  else if x==lst
   then getAns' xs lst (lstCnt+1) ans
  else
   getAns' xs x 1 ans
 in getAns' x 0 0 0

main::IO()
main =
 do
 input <- getContents
 let
  numbers = fmap toInt (split " \n" input)
  n = head numbers
  id = sort [x|x<-(tail numbers),x/=0]
 print $ getAns id


One day student Vasya was sitting on a lecture and mentioned a string s1s2... sn, consisting of letters "a", "b" and "c" that was written on his desk. As the lecture was boring, Vasya decided to complete the picture by composing a graph G with the following properties:   G has exactly n vertices, numbered from 1 to n.  For all pairs of vertices i and j, where i ≠ j, there is an edge connecting them if and only if characters si and sj are either equal or neighbouring in the alphabet. That is, letters in pairs "a"-"b" and "b"-"c" are neighbouring, while letters "a"-"c" are not. Vasya painted the resulting graph near the string and then erased the string. Next day Vasya's friend Petya came to a lecture and found some graph at his desk. He had heard of Vasya's adventure and now he wants to find out whether it could be the original graph G, painted by Vasya. In order to verify this, Petya needs to know whether there exists a string s, such that if Vasya used this s he would produce the given graph G.

NoteIn the first sample you are given a graph made of two vertices with an edge between them. So, these vertices can correspond to both the same and adjacent letters. Any of the following strings "aa", "ab", "ba", "bb", "bc", "cb", "cc" meets the graph's conditions. In the second sample the first vertex is connected to all three other vertices, but these three vertices are not connected with each other. That means that they must correspond to distinct letters that are not adjacent, but that is impossible as there are only two such letters: a and c.

{-
One day student Vasya was sitting on a lecture and mentioned a string s1 s2... sn,
onsisting of letters "a", "b" and "c" that was written on his desk. As the
lecture was boring, Vasya decided to complete the picture by composing
a graph G with the following properties:

 * G has exactly n vertices, numbered from 1 to n.
 * For all pairs of vertices i and j, where i ≠ j, there is an edge connecting
   them if and only if characters si and sj are either equal or neighbouring
   in the alphabet. That is, letters in pairs "a"-"b" and "b"-"c" are
   neighbouring, while letters "a"-"c" are not.

Vasya painted the resulting graph near the string and then erased the string.
Next day Vasya's friend Petya came to a lecture and found some graph at his desk.
He had heard of Vasya's adventure and now he wants to find out whether it could
be the original graph G, painted by Vasya. In order to verify this, Petya needs
to know whether there exists a string s, such that if Vasya used this s he would
produce the given graph G.

Input
The first line of the input contains two integers n and m  — the number of
vertices and edges in the graph found by Petya, respectively.

Each of the next m lines contains two integers ui and vi (1 ≤ ui, vi ≤ n, ui ≠ vi)
— the edges of the graph G. It is guaranteed, that there are no multiple edges,
that is any pair of vertexes appear in this list no more than once.

Output
In the first line print "Yes" (without the quotes), if the string s Petya is
interested in really exists and "No" (without the quotes) otherwise.

If the string s exists, then print it on the second line of the output. The
length of s must be exactly n, it must consist of only letters "a", "b" and "c"
only, and the graph built using this string must coincide with G. If there are
multiple possible answers, you may print any of them.

Found at: http://codeforces.com/contest/624/problem/C
-}

module Main where
import qualified Data.Foldable as Foldable
import Data.Char (ord)
import qualified Data.Set as Set

solve :: Int -> Set.Set (Int,Int) -> Maybe String
solve n edges
  = if Foldable.all (\a -> isFullyConnected a aPositions edges) aPositions
    && Foldable.all (\c -> isFullyConnected c cPositions edges) cPositions
      then Just $ makeExample n aPositions bPositions cPositions
      else Nothing
  where bPositions  = Set.fromList $ filter (\u -> isFullyConnected u (Set.fromList [1..n]) edges) [1..n]
        acPositions = Set.difference (Set.fromList [1..n]) bPositions
        (aPositions, cPositions) = partition2 acPositions edges

partition2 :: Set.Set Int -> Set.Set (Int,Int) -> (Set.Set Int, Set.Set Int)
partition2 vertices edges
  | Set.null vertices = (Set.empty, Set.empty)
  | otherwise         = (aPositions, cPositions)
  where aPositions = visitTransitive (head verticesList) vertices edges
        cPositions = Set.difference vertices aPositions
        verticesList = Set.toList vertices

visitTransitive :: Int -> Set.Set Int -> Set.Set (Int,Int) -> Set.Set Int
visitTransitive start vertices edges = grow Set.empty (Set.singleton start)
  where grow visited toVisit
          | Set.null toVisit = visited
          | otherwise        = grow (Set.union visited toVisit) toVisit'
          where toVisit' = Set.fromList $ [v | u <- Set.toList toVisit,
                                               v <- Set.toList vertices,
                                               v `Set.notMember` (Set.union visited toVisit),
                                               (u,v) `Set.member` edges]

makeExample n aPositions bPositions cPositions = map idxToChar [1..n]
  where idxToChar idx
          | idx `Set.member` aPositions = 'a'
          | idx `Set.member` bPositions = 'b'
          | idx `Set.member` cPositions = 'c'

isFullyConnected v toVertices edges =
  all (`Set.member` edges) expectedEdges
    where expectedEdges = [(u, v) | u <- (Set.toList toVertices), u /= v]

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

main :: IO ()
main = do
  line1 <- getLine
  let [n, m] = map read (words line1) :: [Int]

  edgeLines <- getLines m
  let edgeList = map ((\[a,b] -> (a,b)) . map read . words) edgeLines :: [(Int,Int)]
      -- the set will include also reverse edges
      edgeSet = Set.fromList $ edgeList ++ map (\(u,v) -> (v,u)) edgeList

  case solve n edgeSet of
    Just sampleSolution -> do
      putStrLn "Yes"
      putStrLn sampleSolution
    Nothing ->
      putStrLn "No"

{-
instructions go here...
-}

module Main where
import Data.Char (ord)

solve :: Int -> [(Int,Int)] -> Maybe String
solve n edges = solve' ""
  where solve' :: String -> Maybe String
        solve' str
          | length str == n = Just str
          | otherwise       = case results of
                               []                  -> Nothing
                               (Just solution : _) -> Just solution
          where strs = filter (isValidLastChar edges) [str ++ [addition] | addition <- "abc"] -- not ideal O(n) concat
                results = filter isJust (map solve' strs)

isValidLastChar edges str
  | length str <= 1  = True
  | otherwise        = all (\edge -> edge `elem` edges) expectedEdges && all (\edge -> not $ edge `elem` edges) unexpectedEdges
  where lastChar = last str
        lastCharIdx = length str
        expectedEdges   = [(i,lastCharIdx) | (i,c) <- zip [1..lastCharIdx-1] str, isAdjacent c lastChar]
        unexpectedEdges = [(i,lastCharIdx) | (i,c) <- zip [1..lastCharIdx-1] str, not $ isAdjacent c lastChar]
        isAdjacent x y = abs (ord x - ord y) <= 1

isJust (Just _) = True
isJust Nothing  = False

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

main :: IO ()
main = do
  line1 <- getLine
  let [n, m] = map read (words line1) :: [Int]

  edgeLines <- getLines m
  let edges = map ((\[a,b] -> (a,b)) . map read . words) edgeLines :: [(Int,Int)]

  case solve n edges of
    Just sampleSolution -> do
      putStrLn "Yes"
      putStrLn sampleSolution
    Nothing ->
      putStrLn "No"

{-
instructions go here...
-}

module Main where
import Data.Char (ord)

solve :: Int -> [(Int,Int)] -> Maybe String
solve n edges = if all (\a -> isFullyConnected a aPositions edges) aPositions
                && all (\b -> isFullyConnected b bPositions edges) bPositions
                && all (\c -> isFullyConnected c cPositions edges) cPositions
                  then Just $ makeExample n aPositions bPositions cPositions
                  else Nothing
  where --bPositions  = filter (\u -> isFullyConnected u [1..n] edges) [1..n]
        someB = findFullyConnected [1..n] edges
        bPositions = case someB of (Just bPos) -> visitTransitive bPos [1..n] edges
                                   Nothing     -> []
        acPositions = filter (`notElem` bPositions) [1..n]
        (aPositions, cPositions) = partition2 acPositions edges

partition2 :: [Int] -> [(Int,Int)] -> ([Int],[Int])
partition2 [] _ = ([],[])
partition2 vertices edges = (aPositions, cPositions)
  where aPositions = visitTransitive (head vertices) vertices edges -- grow [] [head vertices]
        cPositions = [v | v <- vertices, v `notElem` aPositions]

findFullyConnected vertices edges
  | null vertices                                   = Nothing
  | isFullyConnected (head vertices) vertices edges = Just (head vertices)
  | otherwise                                       = findFullyConnected (tail vertices) edges

visitTransitive start vertices edges = grow [] [start]
  where grow visited toVisit
          | null toVisit = visited
          | otherwise    = grow (visited ++ toVisit) toVisit'
          where toVisit' = [v | u <- toVisit,
                                v <- vertices,
                                v `notElem` (visited ++ toVisit),
                                (u,v) `elem` edges || (v,u) `elem` edges]

makeExample n aPositions bPositions cPositions = map idxToChar [1..n]
  where idxToChar idx
          | idx `elem` aPositions = 'a'
          | idx `elem` bPositions = 'b'
          | idx `elem` cPositions = 'c'

isFullyConnected v toVertices edges =
  all (\(u,v) -> (u,v) `elem` edges || (v,u) `elem` edges) expectedEdges
    where expectedEdges = [(u, v) | u <- toVertices, u /= v]

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

main :: IO ()
main = do
  line1 <- getLine
  let [n, m] = map read (words line1) :: [Int]

  edgeLines <- getLines m
  let edges = map ((\[a,b] -> (a,b)) . map read . words) edgeLines :: [(Int,Int)]

  case solve n edges of
    Just sampleSolution -> do
      putStrLn "Yes"
      putStrLn sampleSolution
    Nothing ->
      putStrLn "No"

{-
instructions go here...
-}

module Main where
import Data.Char (ord)

solve :: Int -> [(Int,Int)] -> Maybe String
solve n edges = solve' ""
  where solve' :: String -> Maybe String
        solve' str
          | length str == n = Just str
          | otherwise       = case results of
                               []                  -> Nothing
                               (Just solution : _) -> Just solution
          where strs = filter (isValidLastChar edges) [str ++ [addition] | addition <- "abc"] -- not ideal O(n) concat
                results = filter isJust (map solve' strs)

isValidLastChar edges str
  | length str <= 1  = True
  | otherwise        = all (\edge -> edge `elem` edges) expectedEdges && all (\edge -> not $ edge `elem` edges) unexpectedEdges
  where lastChar = last str
        lastCharIdx = length str
        expectedEdges   = [(i,lastCharIdx) | (i,c) <- zip [1..lastCharIdx] str, isAdjacent c lastChar]
        unexpectedEdges = [(i,lastCharIdx) | (i,c) <- zip [1..lastCharIdx] str, not $ isAdjacent c lastChar]
        isAdjacent x y = abs (ord x - ord y) <= 1

isJust (Just _) = True
isJust Nothing  = False

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

main :: IO ()
main = do
  line1 <- getLine
  let [n, m] = map read (words line1) :: [Int]

  edgeLines <- getLines m
  let edges = map ((\[a,b] -> (a,b)) . map read . words) edgeLines :: [(Int,Int)]

  case solve n edges of
    Just sampleSolution -> do
      putStrLn "Yes"
      putStrLn sampleSolution
    Nothing ->
      putStrLn "No"


It is well known that Berland has n cities, which form the Silver ring — cities i and i + 1 (1 ≤ i < n) are connected by a road, as well as the cities n and 1. The goverment have decided to build m new roads. The list of the roads to build was prepared. Each road will connect two cities. Each road should be a curve which lies inside or outside the ring. New roads will have no common points with the ring (except the endpoints of the road).Now the designers of the constructing plan wonder if it is possible to build the roads in such a way that no two roads intersect (note that the roads may intersect at their endpoints). If it is possible to do, which roads should be inside the ring, and which should be outside?

The first line contains two integers n and m (4 ≤ n ≤ 100, 1 ≤ m ≤ 100). Each of the following m lines contains two integers ai and bi (1 ≤ ai, bi ≤ n, ai ≠ bi). No two cities will be connected by more than one road in the list. The list will not contain the roads which exist in the Silver ring.

If it is impossible to build the roads in such a way that no two roads intersect, output Impossible. Otherwise print m characters. i-th character should be i, if the road should be inside the ring, and o if the road should be outside the ring. If there are several solutions, output any of them.

import Control.Monad
import Data.Array
import List

main = do
	[n, m] <- getA
	e <- replicateM m getA
	putStr $ show' $ gao m $ listArray (1, m) $ map sort e where
		getA = fmap (map read . words) getLine
		show' (Just a) = elems a
		show' _ = "Impossible"

inter x@[a,b] y@[c,d] = if a > c then inter y x else a < c && c < b && b < d

gao n e = foldl f (Just $ listArray (1, n) $ repeat '?') [1 .. n] where
	f z@(Just a) i = if a!i == '?' then g 'o' z i else z
	f _ _ = Nothing
	g c z@(Just a) i = if a!i == c then z else if a!i /= '?' then Nothing else r where
		b = filter (\j -> inter (e!i) (e!j)) [1 .. n]
		d = if c == 'o' then 'i' else 'o'
		r = foldl (g d) (Just $ a // [(i, c)]) b
	g _ _ _ = Nothing

import Control.Monad
import Data.Array
import List

main = do
	[n, m] <- getA
	e <- replicateM m getA
	putStr $ show' $ gao m $ listArray (1, m) $ map sort e where
		getA = fmap (map read . words) getLine
		show' Nothing = "Impossible"
		show' (Just a) = elems a

inter (x@[a,b]) (y@[c,d]) = if a > c then inter y x else a < c && c < b && b < d

gao n e = foldl f (Just $ listArray (1, n) $ repeat '?') [1 .. n] where
	f Nothing _ = Nothing
	f (Just a) i = if a!i == '?' then g 'o' (Just a) i else Just a
	g _ Nothing _ = Nothing
	g c (Just a) i = if a!i == c then Just a else if a!i /= '?' then Nothing else r where
		b = filter (\j -> inter (e!i) (e!j)) [1 .. n]
		d = if c == 'o' then 'i' else 'o'
		r = foldl (g d) (Just $ a // [(i, c)]) b

import Data.Array.MArray (newArray, writeArray, readArray)
import List (tails)
import Array (Array, bounds, elems, indices, accumArray, (!))
import Data.Array.MArray (unsafeFreeze)
import Data.Array.ST (STArray)
import Control.Monad (forM, when)
import Control.Monad.ST (ST, runST)

edges :: [(Int, Int)] -> [(Int, Int)]
edges xs =
  concatMap (\ ((a, (_, _)), (b, (_, _))) -> [(a, b), (b, a)]) $
            filter crossing [(x, y) | x:xs <- tails indexed, y <- xs]
  where
  indexed = zip [1..] $ map (\ (a, b) -> (min a b, max a b)) xs
  crossing ((_, (a, b)), (_, (c, d))) = a < c && c < b && b < d ||
                                        c < a && a < d && d < b

bicolor g = runST $ do
  colors <- newArray (bounds g) Nothing :: ST s (STArray s Int (Maybe Bool))
  flags <- forM (indices g) $ \v -> do
    c <- readArray colors v
    if c == Nothing then dfs colors v True
                    else return True
  if all id flags then do
      result <- unsafeFreeze colors
      return (Just result)
    else
      return Nothing
  where
  dfs colors v color = do
    c <- readArray colors v
    case c of
      Nothing -> do
        writeArray colors v (Just color)
        flags <- forM (g ! v) $ \v' ->
          dfs colors v' (not color)
        return (all id flags)
      Just c | c == color -> return True
             | otherwise  -> return False

answer :: Int -> [(Int, Int)] -> String
answer n xs =
  case bicolor $ accumArray (flip (:)) [] (1, n) (edges xs) of
    Just a -> map (\ (Just c) -> if c then 'i' else 'o') $ elems a
    Nothing -> "Impossible"

solve xs = answer n roads
  where
  n = read $ (!! 1) $ words $ head ls
  roads = map ((\ [a, b] -> (read a, read b)) . words) $ tail ls
  ls = lines xs

main = interact solve

import Maybe (isNothing)
import List (sortBy, tails, find, group)
import Array (Array, array, bounds, elems, assocs, accumArray, (!), (//))

crossing :: ((Int, (Int, Int)), (Int, (Int, Int))) -> Bool
crossing ((_, (a, b)), (_, (c, d))) = check $
                            sortBy (\ (a, _, _) (b, _, _) -> compare a b) $
                            [(a, False, 0), (b, True, 0),
                             (c, False, 1), (d, True, 1)]
  where
    check [(a, False, na), (b, False, nb), (c, True, nc), (d, True, nd)]
          | na == nc && nb == nd && (length $ group $ [a, b, c, d]) == 4 = True
    check _ = False

edges :: [(Int, Int)] -> [(Int, Int)]
edges xs = concatMap (\ ((a, (_, _)), (b, (_, _))) -> [(a, b), (b, a)]) $
           filter crossing [(x, y) | x:xs <- tails indexed, y <- xs]
  where
    indexed = zip [1..] $ map (\ (a, b) -> (min a b, max a b)) xs

bicolor :: Array Int [Int] -> Maybe (Array Int (Maybe Bool))
bicolor g =
  let (a, b) = bounds g in
  loop (array (a, b) ((a, Just False):[(i, Nothing) | i <- [a+1..b]])) [1]
  where
    loop colors [] =
      case find (isNothing . snd) (assocs colors) of
        Just (i, _) -> loop (colors // [(i, Just False)]) [i]
        Nothing -> Just colors
    loop colors (v:vs) =
      if all correct adj then
        let new = filter (\v' -> isNothing (colors ! v')) adj in
        loop (colors // [(v', Just (not c)) | v' <- new]) (vs ++ new)
      else
        Nothing
      where
        Just c = colors ! v
        adj = g ! v
        correct v' = case colors ! v' of
                       Just c' -> c' == not c
                       Nothing -> True

answer :: Int -> [(Int, Int)] -> String
answer n xs =
  case bicolor $ accumArray (flip (:)) [] (1, n) (edges xs) of
    Just a -> map (\ (Just c) -> if c then 'i' else 'o') $ elems a
    Nothing -> "Impossible"

solve xs = answer n roads
  where
    n = read $ (!! 1) $ words $ head ls
    roads = map ((\ [a, b] -> (read a, read b)) . words) $ tail ls
    ls = lines xs

main = interact solve

import Data.Array.MArray (newArray, writeArray, readArray)
import List (tails)
import Array (Array, bounds, elems, indices, accumArray, (!))
import Data.Array.MArray (unsafeFreeze)
import Data.Array.ST (STArray)
import Control.Monad (forM, when)
import Control.Monad.ST.Lazy (ST, runST)

edges :: [(Int, Int)] -> [(Int, Int)]
edges xs =
  concatMap (\ ((a, (_, _)), (b, (_, _))) -> [(a, b), (b, a)]) $
            filter crossing [(x, y) | x:xs <- tails indexed, y <- xs]
  where
  indexed = zip [1..] $ map (\ (a, b) -> (min a b, max a b)) xs
  crossing ((_, (a, b)), (_, (c, d))) = a < c && c < b && b < d ||
                                        c < a && a < d && d < b

bicolor g = runST $ do
  colors <- newArray (bounds g) Nothing :: ST s (STArray s Int (Maybe Bool))
  flags <- forM (indices g) $ \v -> do
    c <- readArray colors v
    result <- dfs colors v True
    return (c /= Nothing || result)
  result <- unsafeFreeze colors
  return (all id flags, result)
  where
  dfs colors v color = do
    c <- readArray colors v
    case c of
      Nothing -> do
        writeArray colors v (Just color)
        flags <- forM (g ! v) $ \v' -> dfs colors v' (not color)
        return (all id flags)
      Just c -> return (c == color)

answer :: Int -> [(Int, Int)] -> String
answer n xs =
  case bicolor $ accumArray (flip (:)) [] (1, n) (edges xs) of
    (True, a) -> map (\ (Just c) -> if c then 'i' else 'o') $ elems a
    _ -> "Impossible"

solve xs = answer n roads
  where
  n = read $ (!! 1) $ words $ head ls
  roads = map ((\ [a, b] -> (read a, read b)) . words) $ tail ls
  ls = lines xs

main = interact solve

import Maybe (isNothing)
import List (tails, find)
import Array (Array, array, bounds, elems, assocs, accumArray, (!), (//))

edges :: [(Int, Int)] -> [(Int, Int)]
edges xs = concatMap (\ ((a, (_, _)), (b, (_, _))) -> [(a, b), (b, a)]) $
           filter crossing [(x, y) | x:xs <- tails indexed, y <- xs]
  where
    indexed = zip [1..] $ map (\ (a, b) -> (min a b, max a b)) xs
    crossing ((_, (a, b)), (_, (c, d))) = a < c && c < b && b < d ||
                                          c < a && a < d && d < b

bicolor :: Array Int [Int] -> Maybe (Array Int (Maybe Bool))
bicolor g =
  let (a, b) = bounds g in
  loop (array (a, b) ((a, Just False):[(i, Nothing) | i <- [a+1..b]])) [1]
  where
    loop colors [] =
      case find (isNothing . snd) (assocs colors) of
        Just (i, _) -> loop (colors // [(i, Just False)]) [i]
        Nothing -> Just colors
    loop colors (v:vs) =
      if all correct adj then
        let new = filter (isNothing . (colors !)) adj in
        loop (colors // [(v', Just (not c)) | v' <- new]) (vs ++ new)
      else
        Nothing
      where
        Just c = colors ! v
        adj = g ! v
        correct v' = case colors ! v' of
                       Just c' -> c' == not c
                       Nothing -> True

answer :: Int -> [(Int, Int)] -> String
answer n xs =
  case bicolor $ accumArray (flip (:)) [] (1, n) (edges xs) of
    Just a -> map (\ (Just c) -> if c then 'i' else 'o') $ elems a
    Nothing -> "Impossible"

solve xs = answer n roads
  where
    n = read $ (!! 1) $ words $ head ls
    roads = map ((\ [a, b] -> (read a, read b)) . words) $ tail ls
    ls = lines xs

main = interact solve

import Maybe (isNothing)
import List (sortBy, tails, find, group)
import Array (Array, array, bounds, elems, assocs, accumArray, (!), (//))

crossing :: ((Int, (Int, Int)), (Int, (Int, Int))) -> Bool
crossing ((_, (a, b)), (_, (c, d))) = a < c && c < b && b < d ||
                                      c < a && a < d && d < b

edges :: [(Int, Int)] -> [(Int, Int)]
edges xs = concatMap (\ ((a, (_, _)), (b, (_, _))) -> [(a, b), (b, a)]) $
           filter crossing [(x, y) | x:xs <- tails indexed, y <- xs]
  where
    indexed = zip [1..] $ map (\ (a, b) -> (min a b, max a b)) xs

bicolor :: Array Int [Int] -> Maybe (Array Int (Maybe Bool))
bicolor g =
  let (a, b) = bounds g in
  loop (array (a, b) ((a, Just False):[(i, Nothing) | i <- [a+1..b]])) [1]
  where
    loop colors [] =
      case find (isNothing . snd) (assocs colors) of
        Just (i, _) -> loop (colors // [(i, Just False)]) [i]
        Nothing -> Just colors
    loop colors (v:vs) =
      if all correct adj then
        let new = filter (\v' -> isNothing (colors ! v')) adj in
        loop (colors // [(v', Just (not c)) | v' <- new]) (vs ++ new)
      else
        Nothing
      where
        Just c = colors ! v
        adj = g ! v
        correct v' = case colors ! v' of
                       Just c' -> c' == not c
                       Nothing -> True

answer :: Int -> [(Int, Int)] -> String
answer n xs =
  case bicolor $ accumArray (flip (:)) [] (1, n) (edges xs) of
    Just a -> map (\ (Just c) -> if c then 'i' else 'o') $ elems a
    Nothing -> "Impossible"

solve xs = answer n roads
  where
    n = read $ (!! 1) $ words $ head ls
    roads = map ((\ [a, b] -> (read a, read b)) . words) $ tail ls
    ls = lines xs

main = interact solve

import Control.Monad
import Data.Array
import List

main = do
	[n, m] <- getA
	e <- replicateM m getA
	putStr $ show' $ gao m $ listArray (1, m) $ map sort e where
		getA = fmap (map read . words) getLine
		show' (Just a) = elems a
		show' _ = "Impossible"

inter x@[a,b] y@[c,d] = if a > c then inter y x else a < c && c < b && b < d

gao n e = foldl f (Just $ listArray (1, n) $ repeat '?') [1 .. n] where
	f z@(Just a) i = if a!i == '?' then g 'o' z i else z
	f _ _ = Nothing
	g c z@(Just a) i = case a!i of { '?' -> r; c -> z; d -> Nothing } where
		b = filter (\j -> inter (e!i) (e!j)) [1 .. n]
		d = if c == 'o' then 'i' else 'o'
		r = foldl (g d) (Just $ a // [(i, c)]) b
	g _ _ _ = Nothing

import Data.Array.MArray (newArray, writeArray, readArray)
import List (tails)
import Array (Array, bounds, elems, indices, accumArray, (!))
import Data.Array.MArray (unsafeFreeze)
import Data.Array.ST (STArray)
import Control.Monad (forM, when)
import Control.Monad.ST.Lazy (ST, runST)

edges :: [(Int, Int)] -> [(Int, Int)]
edges xs =
  concatMap (\ ((a, (_, _)), (b, (_, _))) -> [(a, b), (b, a)]) $
            filter crossing [(x, y) | x:xs <- tails indexed, y <- xs]
  where
  indexed = zip [1..] $ map (\ (a, b) -> (min a b, max a b)) xs
  crossing ((_, (a, b)), (_, (c, d))) = a < c && c < b && b < d ||
                                        c < a && a < d && d < b

bicolor g = runST $ do
  colors <- newArray (bounds g) Nothing :: ST s (STArray s Int (Maybe Bool))
  flags <- forM (indices g) $ \v -> do
    c <- readArray colors v
    result <- dfs colors v True
    return (c == Nothing || result)
  result <- unsafeFreeze colors
  return (all id flags, result)
  where
  dfs colors v color = do
    c <- readArray colors v
    case c of
      Nothing -> do
        writeArray colors v (Just color)
        flags <- forM (g ! v) $ \v' -> dfs colors v' (not color)
        return (all id flags)
      Just c -> return (c == color)

answer :: Int -> [(Int, Int)] -> String
answer n xs =
  case bicolor $ accumArray (flip (:)) [] (1, n) (edges xs) of
    (True, a) -> map (\ (Just c) -> if c then 'i' else 'o') $ elems a
    _ -> "Impossible"

solve xs = answer n roads
  where
  n = read $ (!! 1) $ words $ head ls
  roads = map ((\ [a, b] -> (read a, read b)) . words) $ tail ls
  ls = lines xs

main = interact solve

import Maybe (isNothing)
import List (sortBy, tails, find, group)
import Array (Array, array, bounds, elems, assocs, accumArray, (!), (//))

crossing :: ((Int, (Int, Int)), (Int, (Int, Int))) -> Bool
crossing ((_, (a, b)), (_, (c, d))) = check $
                            sortBy (\ (a, _, _) (b, _, _) -> compare a b) $
                            [(a, False, 0), (b, True, 0),
                             (c, False, 1), (d, True, 1)]
  where
    check [(a, False, na), (b, False, nb), (c, True, nc), (d, True, nd)]
          | na == nc && nb == nd && (length $ group $ [a, b, c, d]) == 4 = True
    check _ = False

edges :: [(Int, Int)] -> [(Int, Int)]
edges xs = map (\ ((a, (_, _)), (b, (_, _))) -> (a, b)) $
           filter crossing [(x, y) | x:xs <- tails indexed, y <- xs]
  where
    indexed = zip [1..] $ map (\ (a, b) -> (min a b, max a b)) xs

bicolor :: Array Int [Int] -> Maybe (Array Int (Maybe Bool))
bicolor g =
  let (a, b) = bounds g in
  loop (array (a, b) ((a, Just False):[(i, Nothing) | i <- [a+1..b]])) [1]
  where
    loop colors [] =
      case find (isNothing . snd) (assocs colors) of
        Just (i, _) -> loop (colors // [(i, Just False)]) [i]
        Nothing -> Just colors
    loop colors (v:vs) =
      if all correct adj then
        let new = filter (\v' -> isNothing (colors ! v')) adj in
        loop (colors // [(v', Just (not c)) | v' <- new]) (vs ++ new)
      else
        Nothing
      where
        Just c = colors ! v
        adj = g ! v
        correct v' = case colors ! v' of
                       Just c' -> c' == not c
                       Nothing -> True

answer :: Int -> [(Int, Int)] -> String
answer n xs =
  case bicolor $ accumArray (flip (:)) [] (1, n) (edges xs) of
    Just a -> map (\ (Just c) -> if c then 'i' else 'o') $ elems a
    Nothing -> "Impossible"

solve xs = answer n roads
  where
    n = read $ (!! 1) $ words $ head ls
    roads = map ((\ [a, b] -> (read a, read b)) . words) $ tail ls
    ls = lines xs

main = interact solve