import Data.Word
import Data.Int
import Data.Bits
import Control.Monad
import Control.Applicative
import Control.Arrow
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set(Set)

newtype Mod1b7 = Mod1b7 Int32 deriving (Eq, Ord)

instance Show Mod1b7 where
  show (Mod1b7 x) = show x

moddd :: Num x => x
moddd = 10^9 + 7
instance Num Mod1b7 where
  Mod1b7 x + Mod1b7 y = Mod1b7 ((x + y) `rem` moddd)
  Mod1b7 x * Mod1b7 y = Mod1b7 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `rem` moddd))
  fromInteger x = Mod1b7 (fromInteger $ x `mod` moddd)
  negate (Mod1b7 x) = Mod1b7 ((- x) `mod` moddd)

instance Fractional Mod1b7 where
  recip x = x ^ (moddd - 2)

newtype Mod1b9 = Mod1b9 Int64 deriving (Eq, Ord)

instance Show Mod1b9 where
  show (Mod1b9 x) = show x

moddd9 :: Num x => x
moddd9 = 10^9 + 9
instance Num Mod1b9 where
  Mod1b9 x + Mod1b9 y = Mod1b9 ((x + y) `rem` moddd9)
  Mod1b9 x * Mod1b9 y = Mod1b9 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `rem` moddd9))
  fromInteger x = Mod1b9 (fromInteger $ x `mod` moddd9)
  negate (Mod1b9 x) = Mod1b9 ((- x) `mod` moddd9)

instance Fractional Mod1b9 where
  recip x = x ^ (moddd9 - 2)

data Hash = Hash {-# UNPACK #-} !Mod1b7 {-# UNPACK #-} !Mod1b9 {-# UNPACK #-} !Mod1b7 {-# UNPACK #-} !Mod1b9 deriving (Eq, Show, Ord)

mkHash (Hash l1h l1g h1 g1) (Hash l2h l2g h2 g2) = Hash (l1h * l2h) (l1g * l2g) (h1 * l1h + h2) (g1 * l1g + g2)

data Tree =
  Leaf !Word64 {- 64 bools -}
  | Node  {-# UNPACK #-} !Hash !Tree !Tree (Bool, Tree {- incremented -})
  deriving Show

primHash = uncurry (Hash (2^64) (2^64)) . (fromIntegral &&& fromIntegral)

hash (Leaf x) = primHash x
hash (Node h _ _ _) = h

node :: Tree -> Tree -> Tree
node t1 t2 =
  let res = Node (mkHash (hash t1) (hash t2)) t1 t2 (doIncrement1 res) in res

fullTree 0 = Leaf 0
fullTree n = let x = fullTree (n - 1) in node x x

toDList (Leaf x) = (x:)
toDList (Node _ a b _) = toDList a . toDList b

toList = ($[]) . toDList

i1k t1 (False, t2) = (False, node t1 t2)
i1k t1 (True, t2) = case increment1 t1 of
  (c, t1) -> (c, node t1 t2)

doIncrement1 :: Tree -> (Bool, Tree)
doIncrement1 (Leaf x) = let x' = x + 1 in (x' < x, Leaf x')
doIncrement1 (Node h t1 t2 _) = i1k t1 (increment1 t2)

increment1 (Leaf x) = doIncrement1 (Leaf x)
increment1 (Node _ _ _ x) = x

increment0 :: Int -> Int -> Tree -> (Bool, Tree)
increment0 capacity index0 (Leaf x) = let x' = x + (2 ^ index0) in (x' < x, Leaf x')
increment0 capacity 0 (Node _ _ _ inced) = inced
increment0 capacity index0 (Node h t1 t2 _) | index0 < capacity `div` 2 =
  i1k t1 (increment0 cap2 index0 t2)
 | otherwise = case increment0 cap2 (index0 - cap2) t1 of
   (c, t1) -> (c, node t1 t2)
 where cap2 = capacity `div` 2

instance Eq Tree where
  Leaf x == Leaf y = x == y
  Node h1 _ _ _ == Node h2 _ _ _ = h1 == h2

myCompare (Leaf a) (Leaf b) = compare a b
myCompare (Node h1 l1 r1 _) (Node h2 l2 r2 _)
    | h1 == h2 = EQ
    | otherwise = case myCompare l1 l2 of
      EQ -> myCompare r1 r2
      LT -> LT
      GT -> GT
-- myCompare _ _ = LT

myCompare2 x y = myCompare x y

instance Ord Tree where
    compare = myCompare2

dijkstra :: (Ord path, Ord road, Eq node, Ord node) =>
  (path -> road -> path)
  -> (node -> [(road, node)])
  -> node
  -> Set (path, [node])
  -> Set node
  -> Maybe (path, [node])
dijkstra append edges destination queue visited =
 case Set.minView queue of
  Nothing -> Nothing
  Just ((path, nodes@(node : _)), queue)
   | node == destination -> Just (path, nodes)
   | Set.member node visited -> dijkstra append edges destination queue visited
   | otherwise ->
    dijkstra append edges destination
     (foldl (\s x -> Set.insert x s) queue [(append path road, node' : nodes)|(road,node') <- edges node])
     (Set.insert node visited)

newtype Road = Road Int deriving (Eq, Ord)

-- levels = reverse $ take (17 - 6) $ drop 1 $ iterate (\(Hash a b) -> Hash (a*a) (b*b)) (Hash (2^64) (2^64))

append :: Tree -> Road -> Tree
append t (Road i) = case increment0 (2 ^ 17) i t of
  (False, t) -> t

readInts = map (foldl (\a x -> a * 10 + (fromEnum x - fromEnum '0')) 0) . words <$> getLine

toMod :: [Word64] -> Mod1b7
toMod = foldl (\a x -> a * (2 ^ 64) + fromIntegral x) 0

pp :: Maybe (Mod1b7, [Int]) -> IO ()
pp Nothing = print (-1)
pp (Just (m, l)) = print m >> print (length l) >> putStrLn (unwords $ map show (reverse l))

main = do
  [n,m] <- readInts
  edges <- replicateM m $ do
    [u,v,x] <- readInts
    return (u,v,x)
  [s,t] <- readInts
  let edgeLists = Map.fromListWith (++) (concat [[(u, [(Road x, v)]), (v, [(Road x, u)])] |(u,v,x) <- edges] ++ [(i,[])|i<-[1..n]])
  pp $ fmap (toMod . toList *** id) $ dijkstra append (edgeLists Map.!) t (Set.singleton (fullTree 11, [s])) Set.empty

et = fullTree 3

import Data.Word
import Data.Int
import Data.Bits
import Control.Monad
import Control.Applicative
import Control.Arrow
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set(Set)

newtype Mod1b7 = Mod1b7 Int32 deriving (Eq, Ord)

instance Show Mod1b7 where
  show (Mod1b7 x) = show x

moddd :: Num x => x
moddd = 10^9 + 7
instance Num Mod1b7 where
  Mod1b7 x + Mod1b7 y = Mod1b7 ((x + y) `rem` moddd)
  Mod1b7 x * Mod1b7 y = Mod1b7 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `rem` moddd))
  fromInteger x = Mod1b7 (fromInteger $ x `mod` moddd)
  negate (Mod1b7 x) = Mod1b7 ((- x) `mod` moddd)

instance Fractional Mod1b7 where
  recip x = x ^ (moddd - 2)

newtype Mod1b9 = Mod1b9 Int64 deriving (Eq, Ord)

instance Show Mod1b9 where
  show (Mod1b9 x) = show x

moddd9 :: Num x => x
moddd9 = 10^9 + 9
instance Num Mod1b9 where
  Mod1b9 x + Mod1b9 y = Mod1b9 ((x + y) `rem` moddd9)
  Mod1b9 x * Mod1b9 y = Mod1b9 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `rem` moddd9))
  fromInteger x = Mod1b9 (fromInteger $ x `mod` moddd9)
  negate (Mod1b9 x) = Mod1b9 ((- x) `mod` moddd9)

instance Fractional Mod1b9 where
  recip x = x ^ (moddd9 - 2)

data Hash = Hash {-# UNPACK #-} !Mod1b7 {-# UNPACK #-} !Mod1b9 deriving (Eq, Show, Ord)

mkHash (Hash hl gl) (Hash h1 g1) (Hash h2 g2) = Hash (h1 * hl + h2) (g1 * gl + g2)

data Tree =
  Leaf !Word64 {- 64 bools -}
  | Node  {-# UNPACK #-} !Hash !Tree !Tree
  deriving Show

primHash = uncurry Hash . (fromIntegral &&& fromIntegral)

hash (Leaf x) = primHash x
hash (Node h _ _) = h

node :: Hash -> Tree -> Tree -> Tree
node l t1 t2 = Node (mkHash l (hash t1) (hash t2)) t1 t2

fullTree 0 = Leaf 0
fullTree n = let x = fullTree (n - 1) in node (Hash 0 0) x x

toDList (Leaf x) = (x:)
toDList (Node _ a b) = toDList a . toDList b

toList = ($[]) . toDList

div2h = Hash (recip 2) (recip 2)
hd2 (Hash a b) = case div2h of
  (Hash c d) -> Hash (a * c) (b * d)

increment :: [Hash] -> Int -> Int -> Tree -> (Bool, Tree)
increment _levels capacity index (Leaf x) = let x' = x + (2 ^ (capacity - 1 - index)) in (x' < x, Leaf x')
increment (level : levels) capacity index (Node h t1 t2) | index >= capacity `div` 2 = case increment levels (capacity `div` 2) (index - capacity `div` 2) t2 of
  (False, t2) -> (False, node level t1 t2)
  (True, t2) -> case increment levels (capacity `div` 2) (capacity `div` 2 - 1) t1 of
    (c, t1) -> (c, node level t1 t2)
 | otherwise = case increment levels (capacity `div` 2) index t1 of
   (c, t1) -> (c, node level t1 t2)

instance Eq Tree where
  Leaf x == Leaf y = x == y
  Node h1 _ _ == Node h2 _ _ = h1 == h2

myCompare (Leaf a) (Leaf b) = compare a b
myCompare (Node h1 l1 r1) (Node h2 l2 r2)
    | h1 == h2 = EQ
    | otherwise = case myCompare l1 l2 of
      EQ -> myCompare r1 r2
      LT -> LT
      GT -> GT
-- myCompare _ _ = LT

myCompare2 x y = myCompare x y

instance Ord Tree where
    compare = myCompare2

dijkstra :: (Ord path, Ord road, Eq node, Ord node) =>
  (path -> road -> path)
  -> (node -> [(road, node)])
  -> node
  -> Set (path, [node])
  -> Set node
  -> Maybe (path, [node])
dijkstra append edges destination queue visited =
 case Set.minView queue of
  Nothing -> Nothing
  Just ((path, nodes@(node : _)), queue)
   | node == destination -> Just (path, nodes)
   | Set.member node visited -> dijkstra append edges destination queue visited
   | otherwise ->
    dijkstra append edges destination
     (foldl (\s x -> Set.insert x s) queue [(append path road, node' : nodes)|(road,node') <- edges node])
     (Set.insert node visited)

newtype Road = Road Int deriving (Eq, Ord)

levels = reverse $ take (17 - 6) $ drop 1 $ iterate (\(Hash a b) -> Hash (a*a) (b*b)) (Hash (2^64) (2^64))

append :: Tree -> Road -> Tree
append t (Road i) = case increment levels (2 ^ 17) (2 ^ 17 - 1 - i) t of
  (False, t) -> t

readInts = map (foldl (\a x -> a * 10 + (fromEnum x - fromEnum '0')) 0) . words <$> getLine

toMod :: [Word64] -> Mod1b7
toMod = foldl (\a x -> a * (2 ^ 64) + fromIntegral x) 0

pp :: Maybe (Mod1b7, [Int]) -> IO ()
pp Nothing = print (-1)
pp (Just (m, l)) = print m >> print (length l) >> putStrLn (unwords $ map show (reverse l))

main = do
  [n,m] <- readInts
  edges <- replicateM m $ do
    [u,v,x] <- readInts
    return (u,v,x)
  [s,t] <- readInts
  let edgeLists = Map.fromListWith (++) (concat [[(u, [(Road x, v)]), (v, [(Road x, u)])] |(u,v,x) <- edges] ++ [(i,[])|i<-[1..n]])
  pp $ fmap (toMod . toList *** id) $ dijkstra append (edgeLists Map.!) t (Set.singleton (fullTree 11, [s])) Set.empty

et = fullTree 3

{- tr1 = snd $ increment (Hash (2^9) (2^9)) (2^9) (2^9 - 1 - 64) et
tr2 = snd $ increment (Hash (2^9) (2^9)) (2^9) (2^9 - 1 - 7) et -}

import Data.Word
import Data.Int
import Data.Bits
import Control.Monad
import Control.Applicative
import Control.Arrow
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set(Set)

newtype Mod1b7 = Mod1b7 Int32 deriving (Eq, Ord)

instance Show Mod1b7 where
  show (Mod1b7 x) = show x

moddd :: Num x => x
moddd = 10^9 + 7
instance Num Mod1b7 where
  Mod1b7 x + Mod1b7 y = Mod1b7 ((x + y) `rem` moddd)
  Mod1b7 x * Mod1b7 y = Mod1b7 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `rem` moddd))
  fromInteger x = Mod1b7 (fromInteger $ x `mod` moddd)
  negate (Mod1b7 x) = Mod1b7 ((- x) `mod` moddd)

instance Fractional Mod1b7 where
  recip x = x ^ (moddd - 2)

newtype Mod1b9 = Mod1b9 Int64 deriving (Eq, Ord)

instance Show Mod1b9 where
  show (Mod1b9 x) = show x

moddd9 :: Num x => x
moddd9 = 10^9 + 9
instance Num Mod1b9 where
  Mod1b9 x + Mod1b9 y = Mod1b9 ((x + y) `rem` moddd9)
  Mod1b9 x * Mod1b9 y = Mod1b9 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `rem` moddd9))
  fromInteger x = Mod1b9 (fromInteger $ x `mod` moddd9)
  negate (Mod1b9 x) = Mod1b9 ((- x) `mod` moddd9)

instance Fractional Mod1b9 where
  recip x = x ^ (moddd9 - 2)

data Hash = Hash {-# UNPACK #-} !Mod1b7 {-# UNPACK #-} !Mod1b9 deriving (Eq, Show, Ord)

mkHash (Hash hl gl) (Hash h1 g1) (Hash h2 g2) = Hash (h1 * hl + h2) (g1 * gl + g2)

data Tree =
  Leaf !Word64 {- 64 bools -}
  | Node  {-# UNPACK #-} !Hash !Tree !Tree
  deriving Show

primHash = uncurry Hash . (fromIntegral &&& fromIntegral)

hash (Leaf x) = primHash x
hash (Node h _ _) = h

node :: Hash -> Tree -> Tree -> Tree
node l t1 t2 = Node (mkHash l (hash t1) (hash t2)) t1 t2

inits :: [a] -> [[a]]
inits xs =
  [] : case xs of
    []      -> []
    x : xs' -> map (x :) (inits xs')

p2h n = Hash (2^n) (2^n)

fullTree 0 = Leaf 0
fullTree n = let x = fullTree (n - 1) in node (p2h n) x x

toDList (Leaf x) = (x:)
toDList (Node _ a b) = toDList a . toDList b

toList = ($[]) . toDList

div2h = Hash (recip 2) (recip 2)
hd2 (Hash a b) = case div2h of
  (Hash c d) -> Hash (a * c) (b * d)

increment :: Hash -> Int -> Int -> Tree -> (Bool, Tree)
increment level capacity index (Leaf x) = let x' = x + (2 ^ (capacity - 1 - index)) in (x' < x, Leaf x')
increment level capacity index (Node h t1 t2) | index >= capacity `div` 2 = case increment (hd2 level) (capacity `div` 2) (index - capacity `div` 2) t2 of
  (False, t2) -> (False, node level t1 t2)
  (True, t2) -> case increment level (capacity `div` 2) (capacity `div` 2 - 1) t1 of
    (c, t1) -> (c, node level t1 t2)
 | otherwise = case increment level (capacity `div` 2) index t1 of
   (c, t1) -> (c, node level t1 t2)

instance Eq Tree where
  Leaf x == Leaf y = x == y
  Node h1 _ _ == Node h2 _ _ = h1 == h2
  _ == _ = False

myCompare (Leaf a) (Leaf b) = compare a b
myCompare (Node h1 l1 r1) (Node h2 l2 r2)
    | h1 == h2 = EQ
    | otherwise = case myCompare l1 l2 of
      EQ -> myCompare r1 r2
      LT -> LT
      GT -> GT
-- myCompare _ _ = LT

myCompare2 x y = myCompare x y

instance Ord Tree where
    compare = myCompare2

dijkstra :: (Ord path, Ord road, Eq node, Ord node) =>
  (path -> road -> path) -> (node -> [(road, node)]) -> node -> Set (path, [node]) -> Set node -> Maybe (path, [node])
dijkstra append edges destination queue visited =
    case Set.minView queue of
      Nothing -> Nothing
      Just ((path, nodes@(node : _)), queue)
        | node == destination -> Just (path, nodes)
        | Set.member node visited -> dijkstra append edges destination queue visited
        | otherwise ->
          dijkstra append edges destination
            (foldl (\s x -> Set.insert x s) queue [(append path road, node' : nodes)|(road,node') <- edges node])
            (Set.insert node visited)

newtype Road = Road Int deriving (Eq, Ord)

append :: Tree -> Road -> Tree
append t (Road i) = case increment (Hash (2^17) (2^17)) (2 ^ (17)) (2 ^ (17) - 1 - i) t of
  (False, t) -> t

readInts = map (foldl (\a x -> a * 10 + (fromEnum x - fromEnum '0')) 0) . words <$> getLine

toMod :: [Word64] -> Mod1b7
toMod = foldl (\a x -> a * (2 ^ 64) + fromIntegral x) 0

pp :: Maybe (Mod1b7, [Int]) -> IO ()
pp Nothing = print (-1)
pp (Just (m, l)) = print m >> print (length l) >> putStrLn (unwords $ map show (reverse l))

main = do
  [n,m] <- readInts
  edges <- replicateM m $ do
    [u,v,x] <- readInts
    return (u,v,x)
  [s,t] <- readInts
  let edgeLists = Map.fromListWith (++) (concat [[(u, [(Road x, v)]), (v, [(Road x, u)])] |(u,v,x) <- edges] ++ [(i,[])|i<-[1..n]])
  pp $ fmap (toMod  . toList *** id) $ dijkstra append (edgeLists Map.!) t (Set.singleton (fullTree 11, [s])) Set.empty

import Data.Word
import Data.Int
import Data.Bits
import Control.Monad
import Control.Applicative
import Control.Arrow
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set(Set)

newtype Mod1b7 = Mod1b7 Int64 deriving (Eq, Ord)

instance Show Mod1b7 where
  show (Mod1b7 x) = show x

moddd :: Num x => x
moddd = 10^9 + 7
instance Num Mod1b7 where
  Mod1b7 x + Mod1b7 y = Mod1b7 ((x + y) `mod` moddd)
  Mod1b7 x * Mod1b7 y = Mod1b7 ((x * y) `mod` moddd)
  fromInteger x = Mod1b7 (fromInteger $ x `mod` moddd)
  negate (Mod1b7 x) = Mod1b7 ((- x) `mod` moddd)

instance Fractional Mod1b7 where
  recip x = x ^ (moddd - 2)

data Hash = Hash Int Mod1b7 deriving (Eq, Show, Ord)

mkHash (Hash l1 h1) (Hash l2 h2) = Hash (l1 + l2) (h1 * (2 ^ l1) + h2)

data Tree =
  Leaf !Word64 {- 64 bools -}
  | Node !Hash !Tree !Tree
  deriving Show

primHash = Hash 1 . fromIntegral

hash (Leaf x) = primHash x
hash (Node h _ _) = h

node :: Tree -> Tree -> Tree
node t1 t2 = Node (mkHash (hash t1) (hash t2)) t1 t2

inits :: [a] -> [[a]]
inits xs =
  [] : case xs of
    []      -> []
    x : xs' -> map (x :) (inits xs')

fullTree 0 = Leaf 0
fullTree n = let x = fullTree (n - 1) in node x x

toDList (Leaf x) = (x:)
toDList (Node _ a b) = toDList a . toDList b

toList = ($[]) . toDList

increment :: Int -> Int -> Tree -> (Bool, Tree)
increment capacity index (Leaf x) = let x' = x + (2 ^ (capacity - 1 - index)) in (x' == 0, Leaf x')
increment capacity index (Node h t1 t2) | index >= capacity `div` 2 = case increment  (capacity `div` 2) (index - capacity `div` 2) t2 of
  (False, t2) -> (False, node t1 t2)
  (True, t2) -> case increment  (capacity `div` 2) (capacity `div` 2 - 1) t1 of
    (c, t1) -> (c, node t1 t2)
 | otherwise = case increment (capacity `div` 2) index t1 of
   (c, t1) -> (c, node t1 t2)

instance Eq Tree where
  x == y = compare x y == EQ

myCompare (Leaf a) (Leaf b) = compare a b
myCompare (Node h1 l1 r1) (Node h2 l2 r2)
    | h1 == h2 = EQ
    | otherwise = case myCompare l1 l2 of
      EQ -> myCompare r1 r2
      LT -> LT
      GT -> GT

myCompare2 x y = myCompare x y

instance Ord Tree where
    compare = myCompare2

dijkstra :: (Ord path, Ord road, Eq node, Ord node) =>
  (path -> road -> path) -> (node -> [(road, node)]) -> node -> Set (path, [node]) -> Set node -> Maybe (path, [node])
dijkstra append edges destination queue visited =
    case Set.minView queue of
      Nothing -> Nothing
      Just ((path, nodes@(node : _)), queue)
        | node == destination -> Just (path, nodes)
        | Set.member node visited -> dijkstra append edges destination queue visited
        | otherwise ->
          dijkstra append edges destination
            (foldl (\s x -> Set.insert x s) queue [(append path road, node' : nodes)|(road,node') <- edges node])
            (Set.insert node visited)

newtype Road = Road Int deriving (Eq, Ord)

append :: Tree -> Road -> Tree
append t (Road i) = case increment (2 ^ (17)) (2 ^ (17) - 1 - i) t of
  (False, t) -> t

readInts = map (foldl (\a x -> a * 10 + (fromEnum x - fromEnum '0')) 0) . words <$> getLine

toMod :: [Word64] -> Mod1b7
toMod = foldl (\a x -> a * 2 + fromIntegral x) 0

pp Nothing = print (-1)
pp (Just (m, l)) = print m >> print (length l) >> putStrLn (unwords $ map show (reverse l))

main = do
  [n,m] <- readInts
  edges <- replicateM m $ do
    [u,v,x] <- readInts
    return (u,v,x)
  [s,t] <- readInts
  let edgeLists = Map.fromListWith (++) (concat [[(u, [(Road x, v)]), (v, [(Road x, u)])] |(u,v,x) <- edges] ++ [(i,[])|i<-[1..n]])
  pp $ fmap (toMod  . toList *** id) $ dijkstra append (edgeLists Map.!) t (Set.singleton (fullTree 11, [s])) Set.empty

import Data.Word
import Data.Int
import Data.Bits
import Control.Monad
import Control.Applicative
import Control.Arrow
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set(Set)

newtype Mod1b7 = Mod1b7 Int32 deriving (Eq, Ord)

instance Show Mod1b7 where
  show (Mod1b7 x) = show x

moddd :: Num x => x
moddd = 10^9 + 7
instance Num Mod1b7 where
  Mod1b7 x + Mod1b7 y = Mod1b7 ((x + y) `rem` moddd)
  Mod1b7 x * Mod1b7 y = Mod1b7 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `rem` moddd))
  fromInteger x = Mod1b7 (fromInteger $ x `mod` moddd)
  negate (Mod1b7 x) = Mod1b7 ((- x) `mod` moddd)

instance Fractional Mod1b7 where
  recip x = x ^ (moddd - 2)

newtype Mod1b9 = Mod1b9 Int64 deriving (Eq, Ord)

instance Show Mod1b9 where
  show (Mod1b9 x) = show x

moddd9 :: Num x => x
moddd9 = 10^9 + 9
instance Num Mod1b9 where
  Mod1b9 x + Mod1b9 y = Mod1b9 ((x + y) `rem` moddd9)
  Mod1b9 x * Mod1b9 y = Mod1b9 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `rem` moddd9))
  fromInteger x = Mod1b9 (fromInteger $ x `mod` moddd9)
  negate (Mod1b9 x) = Mod1b9 ((- x) `mod` moddd9)

instance Fractional Mod1b9 where
  recip x = x ^ (moddd9 - 2)

data Hash = Hash {-# UNPACK #-} !Mod1b7 {-# UNPACK #-} !Mod1b9 deriving (Eq, Show, Ord)

mkHash (Hash hl gl) (Hash h1 g1) (Hash h2 g2) = Hash (h1 * hl + h2) (g1 * gl + g2)

data Tree =
  Leaf !Word64 {- 64 bools -}
  | Node  {-# UNPACK #-} !Hash !Tree !Tree
  deriving Show

primHash = uncurry Hash . (fromIntegral &&& fromIntegral)

hash (Leaf x) = primHash x
hash (Node h _ _) = h

node :: Hash -> Tree -> Tree -> Tree
node l t1 t2 = Node (mkHash l (hash t1) (hash t2)) t1 t2

inits :: [a] -> [[a]]
inits xs =
  [] : case xs of
    []      -> []
    x : xs' -> map (x :) (inits xs')

p2h n = Hash (2^n) (2^n)

fullTree 0 = Leaf 0
fullTree n = let x = fullTree (n - 1) in node (Hash 0 0) x x

toDList (Leaf x) = (x:)
toDList (Node _ a b) = toDList a . toDList b

toList = ($[]) . toDList

div2h = Hash (recip 2) (recip 2)
hd2 (Hash a b) = case div2h of
  (Hash c d) -> Hash (a * c) (b * d)

increment :: Hash -> Int -> Int -> Tree -> (Bool, Tree)
increment level capacity index (Leaf x) = let x' = x + (2 ^ (capacity - 1 - index)) in (x' < x, Leaf x')
increment level capacity index (Node h t1 t2) | index >= capacity `div` 2 = case increment (hd2 level) (capacity `div` 2) (index - capacity `div` 2) t2 of
  (False, t2) -> (False, node level t1 t2)
  (True, t2) -> case increment (hd2 level) (capacity `div` 2) (capacity `div` 2 - 1) t1 of
    (c, t1) -> (c, node level t1 t2)
 | otherwise = case increment (hd2 level) (capacity `div` 2) index t1 of
   (c, t1) -> (c, node level t1 t2)

instance Eq Tree where
  Leaf x == Leaf y = x == y
  Node h1 _ _ == Node h2 _ _ = h1 == h2
  _ == _ = False

myCompare (Leaf a) (Leaf b) = compare a b
myCompare (Node h1 l1 r1) (Node h2 l2 r2)
    | h1 == h2 = EQ
    | otherwise = case myCompare l1 l2 of
      EQ -> myCompare r1 r2
      LT -> LT
      GT -> GT
-- myCompare _ _ = LT

myCompare2 x y = myCompare x y

instance Ord Tree where
    compare = myCompare2

dijkstra :: (Ord path, Ord road, Eq node, Ord node) =>
  (path -> road -> path) -> (node -> [(road, node)]) -> node -> Set (path, [node]) -> Set node -> Maybe (path, [node])
dijkstra append edges destination queue visited =
    case Set.minView queue of
      Nothing -> Nothing
      Just ((path, nodes@(node : _)), queue)
        | node == destination -> Just (path, nodes)
        | Set.member node visited -> dijkstra append edges destination queue visited
        | otherwise ->
          dijkstra append edges destination
            (foldl (\s x -> Set.insert x s) queue [(append path road, node' : nodes)|(road,node') <- edges node])
            (Set.insert node visited)

newtype Road = Road Int deriving (Eq, Ord)

append :: Tree -> Road -> Tree
append t (Road i) = case increment (Hash (2^17) (2^17)) (2 ^ (17)) (2 ^ (17) - 1 - i) t of
  (False, t) -> t

readInts = map (foldl (\a x -> a * 10 + (fromEnum x - fromEnum '0')) 0) . words <$> getLine

toMod :: [Word64] -> Mod1b7
toMod = foldl (\a x -> a * (2 ^ 64) + fromIntegral x) 0

pp :: Maybe (Mod1b7, [Int]) -> IO ()
pp Nothing = print (-1)
pp (Just (m, l)) = print m >> print (length l) >> putStrLn (unwords $ map show (reverse l))

main = do
  [n,m] <- readInts
  edges <- replicateM m $ do
    [u,v,x] <- readInts
    return (u,v,x)
  [s,t] <- readInts
  let edgeLists = Map.fromListWith (++) (concat [[(u, [(Road x, v)]), (v, [(Road x, u)])] |(u,v,x) <- edges] ++ [(i,[])|i<-[1..n]])
  pp $ fmap (toMod  . toList *** id) $ dijkstra append (edgeLists Map.!) t (Set.singleton (fullTree 11, [s])) Set.empty

import Data.Word
import Data.Int
import Data.Bits
import Control.Monad
import Control.Applicative
import Control.Arrow
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set(Set)

newtype Mod1b7 = Mod1b7 Int32 deriving (Eq, Ord)

instance Show Mod1b7 where
  show (Mod1b7 x) = show x

moddd :: Num x => x
moddd = 10^9 + 7
instance Num Mod1b7 where
  Mod1b7 x + Mod1b7 y = Mod1b7 ((x + y) `mod` moddd)
  Mod1b7 x * Mod1b7 y = Mod1b7 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `mod` moddd))
  fromInteger x = Mod1b7 (fromInteger $ x `mod` moddd)
  negate (Mod1b7 x) = Mod1b7 ((- x) `mod` moddd)

instance Fractional Mod1b7 where
  recip x = x ^ (moddd - 2)

newtype Mod1b9 = Mod1b9 Int64 deriving (Eq, Ord)

instance Show Mod1b9 where
  show (Mod1b9 x) = show x

moddd9 :: Num x => x
moddd9 = 10^9 + 9
instance Num Mod1b9 where
  Mod1b9 x + Mod1b9 y = Mod1b9 ((x + y) `mod` moddd9)
  Mod1b9 x * Mod1b9 y = Mod1b9 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `mod` moddd9))
  fromInteger x = Mod1b9 (fromInteger $ x `mod` moddd9)
  negate (Mod1b9 x) = Mod1b9 ((- x) `mod` moddd9)

instance Fractional Mod1b9 where
  recip x = x ^ (moddd9 - 2)

data Hash = Hash {-# UNPACK #-} !Mod1b7 {-# UNPACK #-} !Mod1b9 deriving (Eq, Show, Ord)

mkHash l (Hash h1 g1) (Hash h2 g2) = Hash (h1 * (2 ^ l) + h2) (g1 * (2 ^ l) + g2)

data Tree =
  Leaf !Word64 {- 64 bools -}
  | Node  {-# UNPACK #-} !Hash !Tree !Tree
  deriving Show

primHash = uncurry Hash . (fromIntegral &&& fromIntegral)

hash (Leaf x) = primHash x
hash (Node h _ _) = h

node :: Int -> Tree -> Tree -> Tree
node l t1 t2 = Node (mkHash l (hash t1) (hash t2)) t1 t2

inits :: [a] -> [[a]]
inits xs =
  [] : case xs of
    []      -> []
    x : xs' -> map (x :) (inits xs')

fullTree 0 = Leaf 0
fullTree n = let x = fullTree (n - 1) in node n x x

toDList (Leaf x) = (x:)
toDList (Node _ a b) = toDList a . toDList b

toList = ($[]) . toDList

increment :: Int -> Int -> Int -> Tree -> (Bool, Tree)
increment level capacity index (Leaf x) = let x' = x + (2 ^ (capacity - 1 - index)) in (x' == 0, Leaf x')
increment level capacity index (Node h t1 t2) | index >= capacity `div` 2 = case increment level (capacity `div` 2) (index - capacity `div` 2) t2 of
  (False, t2) -> (False, node level t1 t2)
  (True, t2) -> case increment level (capacity `div` 2) (capacity `div` 2 - 1) t1 of
    (c, t1) -> (c, node level t1 t2)
 | otherwise = case increment level (capacity `div` 2) index t1 of
   (c, t1) -> (c, node level t1 t2)

instance Eq Tree where
  x == y = compare x y == EQ

myCompare (Leaf a) (Leaf b) = compare a b
myCompare (Node h1 l1 r1) (Node h2 l2 r2)
    | h1 == h2 = EQ
    | otherwise = case myCompare l1 l2 of
      EQ -> myCompare r1 r2
      LT -> LT
      GT -> GT
myCompare _ _ = LT

myCompare2 x y = myCompare x y

instance Ord Tree where
    compare = myCompare2

dijkstra :: (Ord path, Ord road, Eq node, Ord node) =>
  (path -> road -> path) -> (node -> [(road, node)]) -> node -> Set (path, [node]) -> Set node -> Maybe (path, [node])
dijkstra append edges destination queue visited =
    case Set.minView queue of
      Nothing -> Nothing
      Just ((path, nodes@(node : _)), queue)
        | node == destination -> Just (path, nodes)
        | Set.member node visited -> dijkstra append edges destination queue visited
        | otherwise ->
          dijkstra append edges destination
            (foldl (\s x -> Set.insert x s) queue [(append path road, node' : nodes)|(road,node') <- edges node])
            (Set.insert node visited)

newtype Road = Road Int deriving (Eq, Ord)

append :: Tree -> Road -> Tree
append t (Road i) = case increment 17 (2 ^ (17)) (2 ^ (17) - 1 - i) t of
  (False, t) -> t

readInts = map (foldl (\a x -> a * 10 + (fromEnum x - fromEnum '0')) 0) . words <$> getLine

toMod :: [Word64] -> Mod1b7
toMod = foldl (\a x -> a * 2 + fromIntegral x) 0

pp :: Maybe (Mod1b7, [Int]) -> IO ()
pp Nothing = print (-1)
pp (Just (m, l)) = print m >> print (length l) >> putStrLn (unwords $ map show (reverse l))

main = do
  [n,m] <- readInts
  edges <- replicateM m $ do
    [u,v,x] <- readInts
    return (u,v,x)
  [s,t] <- readInts
  let edgeLists = Map.fromListWith (++) (concat [[(u, [(Road x, v)]), (v, [(Road x, u)])] |(u,v,x) <- edges] ++ [(i,[])|i<-[1..n]])
  pp $ fmap (toMod  . toList *** id) $ dijkstra append (edgeLists Map.!) t (Set.singleton (fullTree 11, [s])) Set.empty

import Data.Word
import Data.Int
import Data.Bits
import Control.Monad
import Control.Applicative
import Control.Arrow
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set(Set)

newtype Mod1b7 = Mod1b7 Int64 deriving (Eq, Ord)

instance Show Mod1b7 where
  show (Mod1b7 x) = show x

moddd :: Num x => x
moddd = 10^9 + 7
instance Num Mod1b7 where
  Mod1b7 x + Mod1b7 y = Mod1b7 ((x + y) `mod` moddd)
  Mod1b7 x * Mod1b7 y = Mod1b7 ((x * y) `mod` moddd)
  fromInteger x = Mod1b7 (fromInteger $ x `mod` moddd)
  negate (Mod1b7 x) = Mod1b7 ((- x) `mod` moddd)

instance Fractional Mod1b7 where
  recip x = x ^ (moddd - 2)

data Hash = Hash Int Mod1b7 deriving (Eq, Show, Ord)

mkHash (Hash l1 h1) (Hash l2 h2) = Hash (l1 + l2) (h1 * (2 ^ l1) + h2)

data Tree =
  Leaf !Word64 {- 64 bools -}
  | Node !Hash !Tree !Tree
  deriving Show

primHash = Hash 1 . fromIntegral

hash (Leaf x) = primHash x
hash (Node h _ _) = h

node :: Tree -> Tree -> Tree
node t1 t2 = Node (mkHash (hash t1) (hash t2)) t1 t2

inits :: [a] -> [[a]]
inits xs =
  [] : case xs of
    []      -> []
    x : xs' -> map (x :) (inits xs')

fullTree 0 = Leaf 0
fullTree n = let x = fullTree (n - 1) in node x x

toDList (Leaf x) = (x:)
toDList (Node _ a b) = toDList a . toDList b

toList = ($[]) . toDList

increment :: Int -> Int -> Tree -> (Bool, Tree)
increment capacity index (Leaf x) = let x' = x + (2 ^ (capacity - 1 - index)) in (x' == 0, Leaf x')
increment capacity index (Node h t1 t2) | index >= capacity `div` 2 = case increment  (capacity `div` 2) (index - capacity `div` 2) t2 of
  (False, t2) -> (False, node t1 t2)
  (True, t2) -> case increment  (capacity `div` 2) (capacity `div` 2 - 1) t1 of
    (c, t1) -> (c, node t1 t2)
 | otherwise = case increment (capacity `div` 2) index t1 of
   (c, t1) -> (c, node t1 t2)

instance Eq Tree where
  x == y = compare x y == EQ

myCompare (Leaf a) (Leaf b) = compare a b
myCompare (Node h1 l1 r1) (Node h2 l2 r2)
    | h1 == h2 = EQ
    | otherwise = case myCompare l1 l2 of
      EQ -> myCompare r1 r2
      LT -> LT
      GT -> GT

myCompare2 x y = myCompare x y

instance Ord Tree where
    compare = myCompare2

dijkstra :: (Ord path, Ord road, Eq node, Ord node) =>
  (path -> road -> path) -> (node -> [(road, node)]) -> node -> Set (path, [node]) -> Set node -> Maybe (path, [node])
dijkstra append edges destination queue visited =
    case Set.minView queue of
      Nothing -> Nothing
      Just ((path, nodes@(node : _)), queue)
        | node == destination -> Just (path, nodes)
        | Set.member node visited -> dijkstra append edges destination queue visited
        | otherwise ->
          dijkstra append edges destination
            (foldl (\s x -> Set.insert x s) queue [(append path road, node' : nodes)|(road,node') <- edges node])
            (Set.insert node visited)

newtype Road = Road Int deriving (Eq, Ord)

append :: Tree -> Road -> Tree
append t (Road i) = case increment (2 ^ (17)) (2 ^ (17) - 1 - i) t of
  (False, t) -> t

readInts = map (foldl (\a x -> a * 10 + (fromEnum x - fromEnum '0')) 0) . words <$> getLine

toMod :: [Word64] -> Mod1b7
toMod = foldl (\a x -> a * 2 + fromIntegral x) 0

pp Nothing = print (-1)
pp (Just (m, l)) = print m >> print (length l) >> putStrLn (unwords $ map show (reverse l))

main = do
  [n,m] <- readInts
  edges <- replicateM m $ do
    [u,v,x] <- readInts
    return (u,v,x)
  [s,t] <- readInts
  print "hi"
  let edgeLists = Map.fromListWith (++) (concat [[(u, [(Road x, v)]), (v, [(Road x, u)])] |(u,v,x) <- edges] ++ [(i,[])|i<-[1..n]])
  pp $ fmap (toMod  . toList *** id) $ dijkstra append (edgeLists Map.!) t (Set.singleton (fullTree 11, [s])) Set.empty

import Data.Word
import Data.Int
import Data.Bits
import Control.Monad
import Control.Applicative
import Control.Arrow
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set(Set)

newtype Mod1b7 = Mod1b7 Int32 deriving (Eq, Ord)

instance Show Mod1b7 where
  show (Mod1b7 x) = show x

moddd :: Num x => x
moddd = 10^9 + 7
instance Num Mod1b7 where
  Mod1b7 x + Mod1b7 y = Mod1b7 ((x + y) `rem` moddd)
  Mod1b7 x * Mod1b7 y = Mod1b7 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `rem` moddd))
  fromInteger x = Mod1b7 (fromInteger $ x `mod` moddd)
  negate (Mod1b7 x) = Mod1b7 ((- x) `mod` moddd)

instance Fractional Mod1b7 where
  recip x = x ^ (moddd - 2)

newtype Mod1b9 = Mod1b9 Int64 deriving (Eq, Ord)

instance Show Mod1b9 where
  show (Mod1b9 x) = show x

moddd9 :: Num x => x
moddd9 = 10^9 + 9
instance Num Mod1b9 where
  Mod1b9 x + Mod1b9 y = Mod1b9 ((x + y) `rem` moddd9)
  Mod1b9 x * Mod1b9 y = Mod1b9 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `rem` moddd9))
  fromInteger x = Mod1b9 (fromInteger $ x `mod` moddd9)
  negate (Mod1b9 x) = Mod1b9 ((- x) `mod` moddd9)

instance Fractional Mod1b9 where
  recip x = x ^ (moddd9 - 2)

data Hash = Hash {-# UNPACK #-} !Mod1b7 {-# UNPACK #-} !Mod1b9 deriving (Eq, Show, Ord)

mkHash (Hash hl gl) (Hash h1 g1) (Hash h2 g2) = Hash (h1 * hl + h2) (g1 * gl + g2)

data Tree =
  Leaf !Word64 {- 64 bools -}
  | Node  {-# UNPACK #-} !Hash !Tree !Tree
  deriving Show

primHash = uncurry Hash . (fromIntegral &&& fromIntegral)

hash (Leaf x) = primHash x
hash (Node h _ _) = h

node :: Hash -> Tree -> Tree -> Tree
node l t1 t2 = Node (mkHash l (hash t1) (hash t2)) t1 t2

inits :: [a] -> [[a]]
inits xs =
  [] : case xs of
    []      -> []
    x : xs' -> map (x :) (inits xs')

p2h n = Hash (2^n) (2^n)

fullTree 0 = Leaf 0
fullTree n = let x = fullTree (n - 1) in node (p2h n) x x

toDList (Leaf x) = (x:)
toDList (Node _ a b) = toDList a . toDList b

toList = ($[]) . toDList

div2h = Hash (recip 2) (recip 2)
hd2 (Hash a b) = case div2h of
  (Hash c d) -> Hash (a * c) (b * d)

increment :: Hash -> Int -> Int -> Tree -> (Bool, Tree)
increment level capacity index (Leaf x) = let x' = x + (2 ^ (capacity - 1 - index)) in (x' == 0, Leaf x')
increment level capacity index (Node h t1 t2) | index >= capacity `div` 2 = case increment (hd2 level) (capacity `div` 2) (index - capacity `div` 2) t2 of
  (False, t2) -> (False, node level t1 t2)
  (True, t2) -> case increment level (capacity `div` 2) (capacity `div` 2 - 1) t1 of
    (c, t1) -> (c, node level t1 t2)
 | otherwise = case increment level (capacity `div` 2) index t1 of
   (c, t1) -> (c, node level t1 t2)

instance Eq Tree where
  Leaf x == Leaf y = x == y
  Node h1 _ _ == Node h2 _ _ = h1 == h2
  _ == _ = False

myCompare (Leaf a) (Leaf b) = compare a b
myCompare (Node h1 l1 r1) (Node h2 l2 r2)
    | h1 == h2 = EQ
    | otherwise = case myCompare l1 l2 of
      EQ -> myCompare r1 r2
      LT -> LT
      GT -> GT
-- myCompare _ _ = LT

myCompare2 x y = myCompare x y

instance Ord Tree where
    compare = myCompare2

dijkstra :: (Ord path, Ord road, Eq node, Ord node) =>
  (path -> road -> path) -> (node -> [(road, node)]) -> node -> Set (path, [node]) -> Set node -> Maybe (path, [node])
dijkstra append edges destination queue visited =
    case Set.minView queue of
      Nothing -> Nothing
      Just ((path, nodes@(node : _)), queue)
        | node == destination -> Just (path, nodes)
        | Set.member node visited -> dijkstra append edges destination queue visited
        | otherwise ->
          dijkstra append edges destination
            (foldl (\s x -> Set.insert x s) queue [(append path road, node' : nodes)|(road,node') <- edges node])
            (Set.insert node visited)

newtype Road = Road Int deriving (Eq, Ord)

append :: Tree -> Road -> Tree
append t (Road i) = case increment (Hash (2^17) (2^17)) (2 ^ (17)) (2 ^ (17) - 1 - i) t of
  (False, t) -> t

readInts = map (foldl (\a x -> a * 10 + (fromEnum x - fromEnum '0')) 0) . words <$> getLine

toMod :: [Word64] -> Mod1b7
toMod = foldl (\a x -> a * 2 + fromIntegral x) 0

pp :: Maybe (Mod1b7, [Int]) -> IO ()
pp Nothing = print (-1)
pp (Just (m, l)) = print m >> print (length l) >> putStrLn (unwords $ map show (reverse l))

main = do
  [n,m] <- readInts
  edges <- replicateM m $ do
    [u,v,x] <- readInts
    return (u,v,x)
  [s,t] <- readInts
  let edgeLists = Map.fromListWith (++) (concat [[(u, [(Road x, v)]), (v, [(Road x, u)])] |(u,v,x) <- edges] ++ [(i,[])|i<-[1..n]])
  pp $ fmap (toMod  . toList *** id) $ dijkstra append (edgeLists Map.!) t (Set.singleton (fullTree 11, [s])) Set.empty

import Data.Word
import Data.Int
import Data.Bits
import Control.Monad
import Control.Applicative
import Control.Arrow
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set(Set)

newtype Mod1b7 = Mod1b7 Int64 deriving (Eq, Ord)

instance Show Mod1b7 where
  show (Mod1b7 x) = show x

moddd :: Num x => x
moddd = 10^9 + 7
instance Num Mod1b7 where
  Mod1b7 x + Mod1b7 y = Mod1b7 ((x + y) `mod` moddd)
  Mod1b7 x * Mod1b7 y = Mod1b7 ((x * y) `mod` moddd)
  fromInteger x = Mod1b7 (fromInteger $ x `mod` moddd)
  negate (Mod1b7 x) = Mod1b7 ((- x) `mod` moddd)

instance Fractional Mod1b7 where
  recip x = x ^ (moddd - 2)

data Hash = Hash {-# UNPACK #-} !Mod1b7 deriving (Eq, Show, Ord)

mkHash l (Hash h1) (Hash h2) = Hash (h1 * (2 ^ l) + h2)

data Tree =
  Leaf !Word64 {- 64 bools -}
  | Node  {-# UNPACK #-} !Hash !Tree !Tree
  deriving Show

primHash = Hash . fromIntegral

hash (Leaf x) = primHash x
hash (Node h _ _) = h

node :: Int -> Tree -> Tree -> Tree
node l t1 t2 = Node (mkHash l (hash t1) (hash t2)) t1 t2

inits :: [a] -> [[a]]
inits xs =
  [] : case xs of
    []      -> []
    x : xs' -> map (x :) (inits xs')

fullTree 0 = Leaf 0
fullTree n = let x = fullTree (n - 1) in node n x x

toDList (Leaf x) = (x:)
toDList (Node _ a b) = toDList a . toDList b

toList = ($[]) . toDList

increment :: Int -> Int -> Int -> Tree -> (Bool, Tree)
increment level capacity index (Leaf x) = let x' = x + (2 ^ (capacity - 1 - index)) in (x' == 0, Leaf x')
increment level capacity index (Node h t1 t2) | index >= capacity `div` 2 = case increment level (capacity `div` 2) (index - capacity `div` 2) t2 of
  (False, t2) -> (False, node level t1 t2)
  (True, t2) -> case increment level (capacity `div` 2) (capacity `div` 2 - 1) t1 of
    (c, t1) -> (c, node level t1 t2)
 | otherwise = case increment level (capacity `div` 2) index t1 of
   (c, t1) -> (c, node level t1 t2)

instance Eq Tree where
  x == y = compare x y == EQ

myCompare (Leaf a) (Leaf b) = compare a b
myCompare (Node h1 l1 r1) (Node h2 l2 r2)
    | h1 == h2 = EQ
    | otherwise = case myCompare l1 l2 of
      EQ -> myCompare r1 r2
      LT -> LT
      GT -> GT
myCompare _ _ = LT

myCompare2 x y = myCompare x y

instance Ord Tree where
    compare = myCompare2

dijkstra :: (Ord path, Ord road, Eq node, Ord node) =>
  (path -> road -> path) -> (node -> [(road, node)]) -> node -> Set (path, [node]) -> Set node -> Maybe (path, [node])
dijkstra append edges destination queue visited =
    case Set.minView queue of
      Nothing -> Nothing
      Just ((path, nodes@(node : _)), queue)
        | node == destination -> Just (path, nodes)
        | Set.member node visited -> dijkstra append edges destination queue visited
        | otherwise ->
          dijkstra append edges destination
            (foldl (\s x -> Set.insert x s) queue [(append path road, node' : nodes)|(road,node') <- edges node])
            (Set.insert node visited)

newtype Road = Road Int deriving (Eq, Ord)

append :: Tree -> Road -> Tree
append t (Road i) = case increment 17 (2 ^ (17)) (2 ^ (17) - 1 - i) t of
  (False, t) -> t

readInts = map (foldl (\a x -> a * 10 + (fromEnum x - fromEnum '0')) 0) . words <$> getLine

toMod :: [Word64] -> Mod1b7
toMod = foldl (\a x -> a * 2 + fromIntegral x) 0

pp :: Maybe (Mod1b7, [Int]) -> IO ()
pp Nothing = print (-1)
pp (Just (m, l)) = print m >> print (length l) >> putStrLn (unwords $ map show (reverse l))

main = do
  [n,m] <- readInts
  edges <- replicateM m $ do
    [u,v,x] <- readInts
    return (u,v,x)
  [s,t] <- readInts
  let edgeLists = Map.fromListWith (++) (concat [[(u, [(Road x, v)]), (v, [(Road x, u)])] |(u,v,x) <- edges] ++ [(i,[])|i<-[1..n]])
  pp $ fmap (toMod  . toList *** id) $ dijkstra append (edgeLists Map.!) t (Set.singleton (fullTree 11, [s])) Set.empty

import Data.Word
import Data.Int
import Data.Bits
import Control.Monad
import Control.Applicative
import Control.Arrow
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set(Set)

newtype Mod1b7 = Mod1b7 Int32 deriving (Eq, Ord)

instance Show Mod1b7 where
  show (Mod1b7 x) = show x

moddd :: Num x => x
moddd = 10^9 + 7
instance Num Mod1b7 where
  Mod1b7 x + Mod1b7 y = Mod1b7 ((x + y) `rem` moddd)
  Mod1b7 x * Mod1b7 y = Mod1b7 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `rem` moddd))
  fromInteger x = Mod1b7 (fromInteger $ x `mod` moddd)
  negate (Mod1b7 x) = Mod1b7 ((- x) `mod` moddd)

instance Fractional Mod1b7 where
  recip x = x ^ (moddd - 2)

newtype Mod1b9 = Mod1b9 Int64 deriving (Eq, Ord)

instance Show Mod1b9 where
  show (Mod1b9 x) = show x

moddd9 :: Num x => x
moddd9 = 10^9 + 9
instance Num Mod1b9 where
  Mod1b9 x + Mod1b9 y = Mod1b9 ((x + y) `rem` moddd9)
  Mod1b9 x * Mod1b9 y = Mod1b9 (fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `rem` moddd9))
  fromInteger x = Mod1b9 (fromInteger $ x `mod` moddd9)
  negate (Mod1b9 x) = Mod1b9 ((- x) `mod` moddd9)

instance Fractional Mod1b9 where
  recip x = x ^ (moddd9 - 2)

data Hash = Hash {-# UNPACK #-} !Mod1b7 {-# UNPACK #-} !Mod1b9 {-# UNPACK #-} !Mod1b7 {-# UNPACK #-} !Mod1b9 deriving (Eq, Show, Ord)

mkHash (Hash l1h l1g h1 g1) (Hash l2h l2g h2 g2) = Hash (l1h * l2h) (l1g * l2g) (h1 * l1h + h2) (g1 * l1g + g2)

data Tree =
  Leaf !Word64 {- 64 bools -}
  | Node  {-# UNPACK #-} !Hash !Tree !Tree (Bool, Tree {- incremented -})
  deriving Show

primHash = uncurry (Hash 2 2) . (fromIntegral &&& fromIntegral)

hash (Leaf x) = primHash x
hash (Node h _ _ _) = h

node :: Tree -> Tree -> Tree
node t1 t2 =
  let res = Node (mkHash (hash t1) (hash t2)) t1 t2 (doIncrement1 res) in res

fullTree 0 = Leaf 0
fullTree n = let x = fullTree (n - 1) in node x x

toDList (Leaf x) = (x:)
toDList (Node _ a b _) = toDList a . toDList b

toList = ($[]) . toDList

i1k t1 (False, t2) = (False, node t1 t2)
i1k t1 (True, t2) = case increment1 t1 of
  (c, t1) -> (c, node t1 t2)

doIncrement1 :: Tree -> (Bool, Tree)
doIncrement1 (Leaf x) = let x' = x + 1 in (x' < x, Leaf x')
doIncrement1 (Node h t1 t2 _) = i1k t1 (increment1 t2)

increment1 (Leaf x) = doIncrement1 (Leaf x)
increment1 (Node _ _ _ x) = x

increment0 :: Int -> Int -> Tree -> (Bool, Tree)
increment0 capacity index0 (Leaf x) = let x' = x + (2 ^ index0) in (x' < x, Leaf x')
increment0 capacity 0 (Node _ _ _ inced) = inced
increment0 capacity index0 (Node h t1 t2 _) | index0 < capacity `div` 2 =
  i1k t1 (increment0 cap2 index0 t2)
 | otherwise = case increment0 cap2 (index0 - cap2) t1 of
   (c, t1) -> (c, node t1 t2)
 where cap2 = capacity `div` 2

instance Eq Tree where
  Leaf x == Leaf y = x == y
  Node h1 _ _ _ == Node h2 _ _ _ = h1 == h2

myCompare (Leaf a) (Leaf b) = compare a b
myCompare (Node h1 l1 r1 _) (Node h2 l2 r2 _)
    | h1 == h2 = EQ
    | otherwise = case myCompare l1 l2 of
      EQ -> myCompare r1 r2
      LT -> LT
      GT -> GT
-- myCompare _ _ = LT

myCompare2 x y = myCompare x y

instance Ord Tree where
    compare = myCompare2

dijkstra :: (Ord path, Ord road, Eq node, Ord node) =>
  (path -> road -> path)
  -> (node -> [(road, node)])
  -> node
  -> Set (path, [node])
  -> Set node
  -> Maybe (path, [node])
dijkstra append edges destination queue visited =
 case Set.minView queue of
  Nothing -> Nothing
  Just ((path, nodes@(node : _)), queue)
   | node == destination -> Just (path, nodes)
   | Set.member node visited -> dijkstra append edges destination queue visited
   | otherwise ->
    dijkstra append edges destination
     (foldl (\s x -> Set.insert x s) queue [(append path road, node' : nodes)|(road,node') <- edges node])
     (Set.insert node visited)

newtype Road = Road Int deriving (Eq, Ord)

-- levels = reverse $ take (17 - 6) $ drop 1 $ iterate (\(Hash a b) -> Hash (a*a) (b*b)) (Hash (2^64) (2^64))

append :: Tree -> Road -> Tree
append t (Road i) = case increment0 (2 ^ 17) i t of
  (False, t) -> t

readInts = map (foldl (\a x -> a * 10 + (fromEnum x - fromEnum '0')) 0) . words <$> getLine

toMod :: [Word64] -> Mod1b7
toMod = foldl (\a x -> a * (2 ^ 64) + fromIntegral x) 0

pp :: Maybe (Mod1b7, [Int]) -> IO ()
pp Nothing = print (-1)
pp (Just (m, l)) = print m >> print (length l) >> putStrLn (unwords $ map show (reverse l))

main = do
  [n,m] <- readInts
  edges <- replicateM m $ do
    [u,v,x] <- readInts
    return (u,v,x)
  [s,t] <- readInts
  let edgeLists = Map.fromListWith (++) (concat [[(u, [(Road x, v)]), (v, [(Road x, u)])] |(u,v,x) <- edges] ++ [(i,[])|i<-[1..n]])
  pp $ fmap (toMod . toList *** id) $ dijkstra append (edgeLists Map.!) t (Set.singleton (fullTree 11, [s])) Set.empty

et = fullTree 3


input :: Int -> [String] -> IO ([String])
input 0 s = return s
input i s = do
  nexts <- getLine
  input (i-1) (s ++ [nexts])

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

solve :: Int -> [[Int]] -> Int -> Int
solve _ [] _ = 0
solve start ([f, t]:lst) step
  | start + step <= f = solve (start+step) ([f,t]:lst) step
  | start > t = solve start lst step
  | otherwise = 1 + solve (start+1) ([f,t]:lst) step

main = do
  inp <- getLine
  let [n, x] = map read (words inp)
  dat <- input n []
  let res = toints dat
--  mapM_ print (res)
  print (solve 1 res x)

import Data.Functor

getInts :: IO [Int]
getInts = map read <$> words <$> getContents

main = getInts >>= putStrLn . show . solve

solve :: [Int] -> Int
solve (n:x:rs) = solve' x 0 rs

solve' x t [] = 0
solve' x t (l:r:rs) = (r-l+1) + mod (l-t-1) x + solve' x r rs

import Control.Monad
solution x l = best l + wait x l
best = sum.map (uncurry subtract)
wait x l = sum $ map (flip mod x) $ zipWith subtract (map snd l) $ tail $ map fst l
readPair = fmap (l2p.map read.words) getLine where l2p [x,y] = (x,y)
main = do
    (n,x) <- readPair
    l <- replicateM n readPair
    print $ solution x $ (1,1):map (fmap (+1)) l

{-# OPTIONS_GHC -O2 -optc-O2 #-}

module Main where

import Control.Applicative
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.Maybe

main :: IO ()
main = do
  [n, x] <- readIntsIO
  lrs <- replicateM n readIntsIO
  print $ solve x lrs

solve :: Int -> [[Int]] -> Int
solve x = go 0 0
  where
    go acc _ [] = acc
    go acc curr ([l, r]:lrs') = go (acc + timeToSkip curr l + (r - l + 1)) r lrs'
    timeToSkip curr next = mod (next - curr - 1) x

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

import Data.List

main = do
    contents <- getContents
    let allLines = lines contents
    let firstLineOfContentAsList = words $ head allLines
    --let nExcitingTimeFrames = firstLineOfContentAsList !! 0
    let skipThisLengthByRemote = read $ firstLineOfContentAsList !! 1
    let excitingTimeFrames = readTimeFrames $ tail allLines
    let lastExcitingFrameEndPoints = map (\(x, y) -> y) $ (0, 0) : init excitingTimeFrames
    let timesCannotSkip = sum $ zipWith (\x (y, z) -> calculateTimeCannotSkip skipThisLengthByRemote x y z) lastExcitingFrameEndPoints excitingTimeFrames
    let timesForWatching = foldl' (\acc (leftTimePoint, rightTimePoint) -> rightTimePoint - leftTimePoint + 1 + acc) 0 excitingTimeFrames
    let minimunTimeSpend = timesCannotSkip + timesForWatching
    print minimunTimeSpend

readTimeFrames :: [String] -> [(Int, Int)]
readTimeFrames [] = []
readTimeFrames (lineToProcess:remainLines) = (twoWordsToTwoInts $ words lineToProcess) : (readTimeFrames remainLines)

twoWordsToTwoInts :: [String] -> (Int, Int)
twoWordsToTwoInts (firstWord:secondWord:remain) = (read firstWord, read secondWord)

calculateTimeCannotSkip :: Int -> Int -> Int -> Int -> Int
calculateTimeCannotSkip skipThisLengthByRemote lastExcitingTimeFrameEndsHere nextExcitingTimeFrameStartsHere nextExcitingTimeFrameEndsHere = (nextExcitingTimeFrameStartsHere - 1 - lastExcitingTimeFrameEndsHere) `mod` skipThisLengthByRemote

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

solve :: [Integer] -> Integer
solve (x:xs) = go 0 xs
  where go t zs@(l:r:ys) | t + x < l = go (t + x) zs
                         | otherwise = r - t + go r ys
        go _ _ = 0
solve _ = undefined

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

solve :: [[Integer]] -> Integer
solve ([_, x]:xs) = go 0 xs
  where go t lrlrs@([ l, r ] : lrs) | t + x < l = go (t + x) lrlrs
                                    | otherwise = r - t + go r lrs
        go _ _ = 0
solve _ = undefined

input 0 s = return s
input i s = do
  nexts <- getLine
  input (i - 1) (s ++ [nexts])

tointlist :: [String] -> [[Int]]
tointlist [] = []
tointlist l = do
    let f = map read $ words $ head l
    let s = tointlist $ tail l
    return f ++ s

localAnswer :: Int -> Int -> Int
localAnswer interval val = (quot interval val) * val

getAnswer :: Int -> Int -> [[Int]] -> Int
getAnswer start x [] = 0
getAnswer start x ([l, r]:ys)
    | x > l - start = l - start + r - l + 1 + getAnswer (r + 1) x ys
    | otherwise = getAnswer (start + localAnswer (l - start) x) x ([l, r]:ys)

main = do
  inp <- getLine
  let [n, x] = map read $ words inp
  interest <- input n []
  let val = getAnswer 1 x $ tointlist interest
  print val

import Control.Applicative
import Data.List

process _ _ [] a =a
process m n (s1:s2:ss) a = process m s2 ss (a+(mod (s1-n-1) m) + s2-s1+1)

main= do
	[n,m]<-map read.words <$>getLine ::IO [Int]
	s<- map read. words <$>getContents
	print $ process m 0 s 0

main = do
	t<-getLine
	rest<-getContents
	let [n,x] = map read $ words t
	let dat = map (map read) $ map words $ lines rest
	putStrLn $ show $ solve 1 x 0 dat

solve cur step all [] = all
solve cur step all (m:ms) | head m - cur >=step = solve (cur+step) step (all) (m:ms)
                          | head m - cur < step = solve (last m+1) step (all+last m - cur+1) ms

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

solve :: [Int] -> Int
solve (n:x:seg) = solve' 0 seg
    where
        solve' :: Int -> [Int] -> Int
        solve' _    []       = 0
        solve' last (l:r:ss) = (mod (l-last-1) x) + (r-l+1) + (solve' r ss)

{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, BangPatterns, OverloadedStrings #-}
{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import Control.Monad hiding ((<$!>))
import Control.Monad.ST.Safe
import Control.Monad.State hiding ((<$!>))
-- 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 qualified Data.Foldable as F
import Data.Function
import Data.Graph
import Data.Int
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Ord
import Data.Ratio
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
-- import Data.Tree
import Data.Tuple
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
-- import Debug.Trace
import System.IO

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

main = do
  [n, x] <- getInts
  lrs <- replicateM n getInts

  let
    count c [] = 0
    count c ([l, r]:lrs) =
      (l-c) `mod` x + (r-l+1) + count (r+1) lrs

  print $ count 1 lrs

main = do
	t<-getLine
	rest<-getContents
	let [n,x] = map read $ words t
	let dat = map (map read) $ map words $ lines rest
	putStrLn $ show $ solve 1 x 1 dat

solve cur step all [] = all
solve cur step all (m:ms) | head m - cur >=step = solve (cur+step) step (all) (m:ms)
                          | head m - cur < step = solve (last m) step (all+last m - cur) ms
                          | otherwise = solve (last m) step (all+ last m - cur) ms

import Control.Monad
solution x l = best l + wait x l
best = sum.map ((+1).uncurry subtract)
wait x l = sum $ map (flip mod x) $ zipWith subtract (map snd l) $ tail $ map fst l
readPair = fmap (l2p.map read.words) getLine where l2p [x,y] = (x,y)
main = do
    (n,x) <- readPair
    l <- replicateM n readPair
    print $ solution x $ (2,1):l

import Control.Monad
solution x l = best l + wait x l
best = sum.map ((+1).uncurry subtract)
wait x l = sum $ map (flip mod x) $ zipWith subtract (map snd l) $ tail $ map fst l
readPair = fmap (l2p.map read.words) getLine where l2p [x,y] = (x,y)
main = do
    (n,x) <- readPair
    l <- replicateM n readPair
    print $ solution x l

{-# OPTIONS_GHC -O2 -optc-O2 #-}

module Main where

import Control.Applicative
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.Maybe

main :: IO ()
main = do
  [n, x] <- readIntsIO
  lrs <- replicateM n readIntsIO
  print $ solve x lrs

solve :: Int -> [[Int]] -> Int
solve x = go 0 (-1)
  where
    go acc _ [] = acc
    go acc curr ([l, r]:lrs') = go (acc + timeToSkip curr l + (r - l + 1)) r lrs'
    timeToSkip curr next = mod (next - curr - 1) x

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

import Control.Applicative
import Data.List

process _ _ [] a =a
process m n (s1:s2:ss) a = process m s2 ss (a+(mod (s1-n-1) 3) + s2-s1+1)
main= do
	[n,m]<-map read.words <$>getLine ::IO [Int]
	s<- map read. words <$>getContents
	print $ process m 0 s 0


import Data.Char
import Data.List
import qualified Data.ByteString.Char8 as BS

skipWhitespace :: BS.ByteString -> BS.ByteString
skipWhitespace = BS.dropWhile (`elem` " \n\t")

readInts :: BS.ByteString -> [Int]
readInts line = case BS.readInt line of Just (x, t) -> x : (readInts (skipWhitespace t))
                                        Nothing -> []

solve :: Int -> Int -> [Int] -> Int
solve n k a = (sum a) - (k * (k - 1) `div` 2) + k * (n - 1) - sum (take k $ reverse $ sort [elem + ind | (elem, ind) <- zip a [0..]])

mainLoop 0 = return ()
mainLoop t = do firstLine <- BS.getLine
                secondLine <- BS.getLine
                let [n, k] = readInts firstLine
                let a = readInts secondLine
                print (solve n k a)
                mainLoop (t - 1)

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

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

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

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

main :: IO ()
main = do
  [t] <- getInts
  output <- fmap mconcat $ replicateM t $ do
    [n, k] <- getInts
    as <- map fromIntegral <$> getInts
    let bs = scanl' (+) 0 $ reverse $ sort $ zipWith (\i a -> a - fromIntegral n + i) [1..] as
        optimal = maximum $ take (k + 1) $ zipWith (\i a -> i * (i - 1) `div` 2 + a) [0..] bs
    return $ int64Dec (sum as - optimal) <> charUtf8 '\n'
  hPutBuilder stdout output


main :: IO ()
main = do
  t <- readLn
  routine t

routine :: Int -> IO ()
routine t
  | t > 1 = do
      solve
      routine (t-1)
  | t == 1 = solve

solve :: IO()
solve = do
  [n,x] <- map read.words <$> getLine
  xs <- map read.words <$> getLine
  putStrLn (if possible n x xs then "Yes" else "No")

possible :: Int -> Int -> [Int] -> Bool
possible n x xs
  | x == n = odd (sum xs)
  | otherwise = do
      let a = take x xs
      let b = drop x xs
      if even (sum a) then ((any even a) && (any odd b)) || ((any odd a) && (any even b))
      else True

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

routine :: IO ()
routine = do
  [n,x] <- (map read.words) <$> getLine
  xs <- (map read.words) <$> getLine
  putStrLn $ if solve n x xs then "Yes" else "No"

solve :: Int -> Int -> [Int] -> Bool
solve n x xs
  | n == x = odd $ sum xs
  | otherwise = b || (odd $ sum $ take x xs)
  where
    b = (any odd xs) && (any even xs)

-- as <- getLine
-- putStrLn (show (foldr (+) 0 (map read (words as))))

getNums :: IO [Int]
getNums = do
    nums <- getLine
    return (map (read :: String -> Int) $ (words nums))

getNum = do
    num <- getLine
    return (read num :: Int)

tuplify2 [x, y] = (x, y)

repeatAction 0 _ = return ()
repeatAction n action = do
    action
    repeatAction (n - 1) action

answer cap o e target =
    if o > fst cap then False
    else if o + e == target then True
         else if e + 1 > snd cap then answer cap (o + 2) 0 target
              else answer cap o (e + 1) target

body = do
    params <- getNums
    values <- getNums

    let (n, x) = tuplify2 params
    let odds = foldr (+) 0 $ map (fromEnum . odd) values
    let evens = n - odds
    let evensFromOdds = odds `div` 2

    putStrLn $ if answer (odds, evens) 1 0 x then "Yes"
               else "No"

    return ()

main = do
    t <- getNum
    repeatAction t body

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

routine :: IO ()
routine = do
    [n, x] <- (map read.words) <$> getLine
    xs <- (map read.words) <$> getLine
    putStrLn $ if (solve x xs) then "No" else "Yes"

solve :: Int -> [Int] -> Bool
solve x a =
    let evens = length $ filter (\x->mod x 2 ==0) a in
    let odds = length a - evens in
    let min_odds = if (evens > x) then 0 else (x - evens) in
    let max_odds = min x odds in
    (min_odds == max_odds) && (mod min_odds 2 == 0)

count :: [Int] -> Int -> Int
count [] n = n
count (x : list) n = count list (n + (mod x 2))
while i = do
    if i == 0 then
        return 0
    else do
        input1 <- getLine
        input2 <- getLine
        let [n, x] = map read (words input1) :: [Int]
        let list = map read (words input2) :: [Int]
        --print count list
        let od = count list 0
        let ev = n - od
        if ev >= x then
            if od > 0 then
                putStrLn "Yes"
            else
                putStrLn "No"
        else do
            let d = x - ev
            if (mod d 2) == 1 then
                putStrLn "Yes"
            else if od > d && ev > 0 then
                putStrLn "Yes"
            else
                putStrLn "No"
        while (i - 1)
main = do
    input <- getLine
    let tests = read input :: (Int)
    while tests

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

import Data.List

--import Debug.Trace

_split acc "" [] = reverse acc
_split acc curr [] = reverse $ reverse curr : acc
_split acc curr (ch:rest)
  | (any (== ch) [' ', '\n']) = _split (reverse curr : acc) "" rest
  | otherwise = _split acc (ch:curr) rest

split = _split [] ""

main = do
  input <- getContents
  let _:tokens = read <$> split input :: [Int]
      res = unfoldr (\ls ->
        case ls of
          []  -> Nothing
          n:k:rest0   ->
            let (vals, rest1) = splitAt n rest0
                anyOdd = any (\x -> x `mod` 2 == 1) vals
                anyEven = any (\x -> x `mod` 2 == 0) vals
                sumParity = foldl (+) 0 vals `mod` 2
                hasChoice = k < n
                res = if
                  | hasChoice   -> anyOdd && (anyEven || k `mod` 2 == 1)
                  | otherwise   -> sumParity == 1
            in Just (if res then "Yes" else "No", rest1)
        ) tokens
  sequence_ $ putStrLn <$> res

import Data.List (unfoldr)
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Lazy.Char8 (readInt)
import Prelude hiding (span, dropWhile)
import Data.Word (Word8)

newLine :: Word8
newLine = 0x0a
space :: Word8
space = 0x20

skipLine :: L.ByteString -> L.ByteString
skipLine = L.dropWhile (== newLine) . L.dropWhile (/= newLine)

readIntLine :: L.ByteString -> ([Int], L.ByteString)
readIntLine str = let
  (currLine, lf) = L.span (/= newLine) str
  (_, rest) = L.span (== newLine) lf
  in (unfoldr (readInt . L.dropWhile (== space)) currLine, rest)

parseCase :: L.ByteString -> Maybe (([Int], Int), L.ByteString)
parseCase str = case  readIntLine str  of
  ([_n, x], xs1) -> Just ((a, x), xs2)  where
    (a, xs2) = readIntLine xs1
  _ -> Nothing

solve :: ([Int], Int) -> Bool
solve (a, x) = let
  (n, k) = go 0 0 a
  go p q [] = (p, q)
  go p q (w:ws) = seq (seq p q) $ go (p+1) (if  odd w  then  q + 1  else  q) ws
  in
    case  ()  of
     ()
      | k == n  -> odd x
      | k == 0  -> False
      | x == n  -> odd k
      | x == 0  -> False
      | otherwise  -> True

pprint :: Bool -> String
pprint True = "Yes\n"
pprint False = "No\n"

main :: IO ()
main = (putStr . concatMap (pprint . solve) . unfoldr parseCase . skipLine)
  =<< L.getContents

groupByNLines :: Int -> [String] -> [[String]]
groupByNLines _ [] = []
groupByNLines n strings = (take n strings):(groupByNLines n (drop n strings))

parse :: [String] -> String
parse [l, arr']
   | solve arr x = "YES"
   | otherwise = "NO"
   where arr = map (\x -> read x :: Integer) $ words arr'
         [_, x] = map (\x -> read x :: Integer) $ words l

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

possibilities :: Integer -> [(Integer, Integer)]
possibilities n = [(i, n-i) | i <- [0..n], odd (n-i)]

solve :: [Integer] -> Integer -> Bool
solve arr x = length (filter (\(e, o) -> numberOfOdd >= o && numberOfEven >= e) pos) > 0
  where numberOfOdd = toInteger $ length $ filter odd arr
        numberOfEven = toInteger $ length $ filter even arr
        pos = possibilities x

-- as <- getLine
-- putStrLn (show (foldr (+) 0 (map read (words as))))

getNums :: IO [Int]
getNums = do
    nums <- getLine
    return (map (read :: String -> Int) $ (words nums))

getNum = do
    num <- getLine
    return (read num :: Int)

tuplify2 [x, y] = (x, y)

repeatAction 0 _ = return ()
repeatAction n action = do
    action
    repeatAction (n - 1) action

body = do
    params <- getNums
    values <- getNums

    let (n, x) = tuplify2 params
    let odds = foldr (+) 0 $ map (fromEnum . odd) values
    let evens = n - odds
    let evensFromOdds = odds `div` 2

    putStrLn $ if odds >= 1 && evens >= x - 1 ||
                  (odd odds) && evens + evensFromOdds >= x - 1 ||
                  (odds >= 2) && evens + evensFromOdds - 1 >= x - 1
               then "Yes"
               else "No"

    return ()

main = do
    t <- getNum
    repeatAction t body

hasEven :: [Integer] -> Bool
hasEven arr = not $ null $ filter even arr

hasOdd :: [Integer] -> Bool
hasOdd arr = not $ null $ filter odd arr

withoutAnEven :: [Integer] -> [Integer]
withoutAnEven arr = (takeWhile odd arr) ++ (tail (dropWhile odd arr))

withoutAnOdd :: [Integer] -> [Integer]
withoutAnOdd arr = (takeWhile even arr) ++ (tail (dropWhile even arr))

atLeastTwoOdd :: [Integer] -> Bool
atLeastTwoOdd arr = (length $ filter odd arr) >= 2

solve :: Integer -> [Integer] -> Bool
solve 1 arr = hasOdd arr
solve x arr
  | null arr = False
  | x <= 0 = False
  | hasEven arr = solve (x-1) (withoutAnEven arr)
  | atLeastTwoOdd arr = solve (x-2) (withoutAnOdd $ withoutAnOdd arr)
  | hasOdd arr = solve (x-1) (withoutAnOdd arr)

groupByNLines :: Int -> [String] -> [[String]]
groupByNLines _ [] = []
groupByNLines n strings = (take n strings):(groupByNLines n (drop n strings))

parse :: [String] -> String
parse [l, arr']
  | solve x arr = "YES"
  | otherwise = "NO"
  where arr = map (\x -> read x :: Integer) $ words arr'
        [_, x] = map (\x -> read x :: Integer) $ words l

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


module Main where

import Data.List
import qualified Data.HashMap.Strict as H

solve :: [Int] -> [Int]
solve ns = go H.empty (zip [1..] ns)
  where
    go :: H.HashMap Int ([Int], Int) -> [(Int, Int)] -> [Int]
    go h [] = reverse $ fst $ snd $ maximumBy (\(_, (_, a)) (_, (_, b)) -> compare a b) (H.toList h)
    go h ((i, x):xs) = case H.lookup (x - 1) h of
      Just (ys, l) -> go (H.insert x (i:ys, l + 1) h) xs
      Nothing -> go (H.insert x ([i], 1) h) xs

main :: IO ()
main = do
  _ <- getLine
  ns <- fmap (map read . words) getLine
  let result = solve ns
  print $ length result
  putStrLn $ unwords (map show result)

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe              #-}
{-# LANGUAGE TupleSections     #-}

import           Control.Applicative
import           Control.Monad
import           Data.Array.Unboxed
import           Data.Bits
import           Data.Bool
import qualified Data.ByteString.Char8 as B
import           Data.Char
import           Data.Function
import           Data.Int
import qualified Data.IntMap.Strict    as IM
import qualified Data.IntSet           as IS
import           Data.List
import qualified Data.Map.Strict       as M
import           Data.Monoid
import           Data.Ord
import qualified Data.Set              as S
import           Data.Tuple
import           Data.Word

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

main :: IO ()
main = do
    n <- readLn :: IO Int
    xs <- unfoldr (B.readInt.B.dropWhile isSpace) <$> B.getLine
    let res = solve n xs
    print $ length res
    putStrLn . unwords . map show $ res

solve :: Int -> [Int] -> [Int]
solve _ xs = construct [1..] xs . subseq $ go IM.empty xs
  where
    go !im (x:xs) = case IM.lookup (x - 1) im of
        Nothing -> go (IM.insert x 1 im) xs
        Just l  -> go (IM.insertWith max x (l + 1) im) xs
    go im [] = maximum [(v,k)|(k,v)<-IM.toList im]
    subseq (v, k) = [k-v+1..k]
    construct (i:is) (x:xs) (y:ys)
        | x == y = i : construct is xs ys
        | otherwise = construct is xs (y:ys)
    construct _ _ _ = []

{-# OPTIONS_GHC -O2 #-}
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe              #-}
{-# LANGUAGE TupleSections     #-}

import           Control.Applicative
import           Control.Monad
import           Data.Array.Unboxed
import           Data.Bits
import           Data.Bool
import qualified Data.ByteString.Char8 as B
import           Data.Char
import           Data.Function
import           Data.Int
import qualified Data.IntMap.Strict    as IM
import qualified Data.IntSet           as IS
import           Data.List
import qualified Data.Map.Strict       as M
import           Data.Monoid
import           Data.Ord
import qualified Data.Set              as S
import           Data.Tuple
import           Data.Word

main :: IO ()
main = do
    n <- readLn :: IO Int
    xs <- unfoldr (B.readInt.B.dropWhile isSpace) <$> B.getLine
    let res = solve n xs
    print $ length res
    putStrLn . unwords $ map show res

solve :: Int -> [Int] -> [Int]
solve _ xs = construct [1..] xs $ go IM.empty xs
  where
    go !im (x:xs) = case IM.lookup (x - 1) im of
        Nothing -> go (IM.insert x 1 im) xs
        Just l  -> go (IM.insertWith max x (l + 1) im) xs
    go im [] = snd $ maximum [(len, [lst-len+1..lst])|(lst, len)<-IM.toList im]
    construct (i:is) (x:xs) (y:ys)
        | x == y = i : construct is xs ys
        | otherwise = construct is xs (y:ys)
    construct _ _ _ = []

import qualified Data.ByteString.Char8 as B
import qualified Data.IntMap as M
import qualified Data.Foldable as F
import Data.List
import Data.Ord
import qualified Data.Sequence as S

main = do
  input <- B.getContents
  let ns =  map readI $ tail $ B.words $ input
  let ans = solve ns
  print (length ans)
  putStrLn $ unwords $  map show ans

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

solve :: [Int] -> [Int]
solve ns =
  F.toList $ M.foldl (\xs ys-> maximumBy (comparing S.length) [xs,ys]) S.empty $ foldl f M.empty $ zip [1..] ns
  where
    f :: M.IntMap (S.Seq Int) -> (Int,Int) -> M.IntMap (S.Seq Int)
    f m (i,x) =
      case M.lookup x m of
        Nothing -> M.alter (Just . g (S.singleton i)) (x+1) m
        Just js -> M.alter (Just . g (js S.|> i)) (x+1) m

    g :: S.Seq Int -> Maybe (S.Seq Int) -> S.Seq Int
    g xs Nothing   = xs
    g xs (Just ys) = maximumBy (comparing S.length) [xs,ys]


s [a, b] = f ('4', '7') `max` f ('7', '4')
  where f z = length $ filter (==z) $ zip a b
main = interact $ show . s . words

{-# 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 qualified Data.Foldable as F
import Data.Function
-- import Data.Graph
import Data.Int
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Ratio
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
-- 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 Debug.Trace
import System.IO

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

main = do
  a <- getLine
  b <- getLine

  let
    c1 = length $ filter (== '4') a
    c2 = length $ filter (== '4') b

    k = abs $ c1-c2

    a' = f a b k
      where
        f [] _ _ = []
        f (x:xs) (y:ys) k
          | x /= y && k > 0 = y:(f xs ys (k-1))
          | otherwise = x:(f xs ys k)

    k2 = (length $ filter id $ zipWith (/=) a' b) `div` 2

  print $ k + k2

is4  =  \ch -> ch == '4'
is7  =  \ch -> ch == '7'
is47 =  \ch -> is4 ch || is7 ch

filterEq :: String -> String -> String
filterEq "" ""  =  ""
filterEq "" _   =  ""
filterEq _ ""   =  ""
filterEq (x:xs) (y:ys)
  | x == y     =  filterEq xs ys
  | otherwise  =  x:(filterEq xs ys)

solve :: String -> String -> Int
solve s1 s2  =  max c4 c7
  where
    s   =  filterEq s1 s2
    c4  =  length (filter is4 s)
    c7  =  length (filter is7 s)

main :: IO ()
main = do
    s1 <- getLine
    s2 <- getLine
    print (solve s1 s2)

s [a, b] = f ('4', '7') `max`  f ('7', '4')
  where f x = length $ filter (==x) $ zip a b
main = interact $ show . s . words

solve a = f ('4','7') `max` f ('7','4')
    where f x = length$filter (==x) $ head a `zip` last a

main=interact$show.solve.lines

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
{-# OPTIONS_GHC -O2 #-}

import Data.List
import Data.Maybe
import Data.Char
import Data.Array.IArray
import Data.Array.Unboxed (UArray)
import Data.Int
import Data.Ratio
import Data.Bits
import Data.Function
import Data.Ord
--import Control.Monad.State
import Control.Monad
import Control.Applicative
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Sequence (Seq, (<|), (|>), (><), ViewL(..), ViewR(..))
import qualified Data.Sequence as Seq
import qualified Data.Foldable as F
import Data.Graph

parseInput = do
    a <- readString
    b <- readString
    return (BS.unpack a, BS.unpack b)
  where
    readInt = state $ fromJust . BS.readInt . BS.dropWhile isSpace
    readInteger = state $ fromJust . BS.readInteger . BS.dropWhile isSpace
    readString = state $ BS.span (not . isSpace) . BS.dropWhile isSpace
    readLine = state $ BS.span (not . isEoln) . BS.dropWhile isEoln
    isEoln ch = ch == '\r' || ch == '\n'

main = print =<< solve . evalState parseInput <$> BS.getContents

solve (x, y) = max cnt47 cnt74
  where
    pairs = zip x y
    cnt47 = length $ filter (== ('4', '7')) pairs
    cnt74 = length $ filter (== ('7', '4')) pairs

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

class (Monad m) => MonadState s m | m -> s where
	get :: m s
	put :: s -> m ()

modify :: (MonadState s m) => (s -> s) -> m ()
modify f = do
	s <- get
	put (f s)

gets :: (MonadState s m) => (s -> a) -> m a
gets f = do
	s <- get
	return (f s)

newtype State s a = State { runState :: s -> (a, s) }

instance Functor (State s) where
	fmap f m = State $ \s -> let
		(a, s') = runState m s
		in (f a, s')

instance Applicative (State s) where
    pure = return
    (<*>) = ap

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

instance MonadState s (State s) where
	get   = State $ \s -> (s, s)
	put s = State $ \_ -> ((), s)

evalState :: State s a -> s -> a
evalState m s = fst (runState m s)

execState :: State s a -> s -> s
execState m s = snd (runState m s)

mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
mapState f m = State $ f . runState m

withState :: (s -> s) -> State s a -> State s a
withState f m = State $ runState m . f

state = State

import Control.Applicative ((<$>), (<*>))
import Control.Arrow ((&&&))

main :: IO ()
main = print =<< solve <$> (zip <$> getLine <*> getLine)

solve :: [(Char, Char)] -> Int
solve = uncurry max <$> (count ('7', '4') &&& count ('4', '7'))

count :: Eq a => a -> [a] -> Int
count a = length . filter (==a)

g :: String -> String -> (Int, Int) -> Int
g [] [] (p, q) = max p q
g ('4':as) ('4':bs) (p, q) = g as bs (p, q)
g ('4':as) ('7':bs) (p, q) = g as bs (p+1, q)
g ('7':as) ('4':bs) (p, q) = g as bs (p, q+1)
g ('7':as) ('7':bs) (p, q) = g as bs (p, q)

main :: IO ()
main = do
  a <- getLine
  b <- getLine
  print $ g a b (0, 0)

import Control.Applicative
import Data.ByteString(ByteString)
import qualified Data.ByteString.Char8 as B

main = do a <- B.getLine
          b <- B.getLine
          print $ solve a b

solve :: ByteString -> ByteString -> Int
solve a b = (d+) $ div (n-d) 2
   where la4 = B.length $ B.filter ('4'==) a
         lb4 = B.length $ B.filter ('4'==) b
         d = abs $ la4 - lb4
         n = length $ filter id $ B.zipWith (/=) a b

module Main where

import Data.List

main = interact $ show . uncurry max . foldl' (\(x, y) [a, b] ->
    if a /= b
        then if a == '4'
            then (x + 1, y)
            else (x, y + 1)
        else (x, y)) (0, 0) . transpose . lines

module Main where

import Data.List

main = interact $ show . uncurry max . foldl (\(x, y) [a, b] ->
    if a /= b
        then if a == '4'
            then (x + 1, y)
            else (x, y + 1)
        else (x, y)) (0, 0) . transpose . lines

x#y=x+y-min x y
s[a,b]=c(<)#c(>)where c f=length.filter id$zipWith f a b
main=interact$show.s.lines

s[a,b]=c(<)`max`c(>)where c f=length.filter id$zipWith f a b
main=interact$show.s.lines

import Data.Char
parse = map (map digitToInt) . lines

solve [a, b] = loop a b 0 0

loop [] [] at ta = max at ta
loop (4:x) (7:y) at ta = loop x y (1 + at) ta
loop (7:x) (4:y) at ta = loop x y at (1 + ta)
loop (_:x) (_:y) at ta = loop x y at ta

main = (print . solve . parse =<< getContents)

count :: (Eq a) => a -> [a] -> Int
count _ [] = 0
count x (a:as) =
    if a == x
    then
        1 + count x as
    else
        count x as

countsev = count '7'

mismatches :: (Eq a) => [a] -> [a] -> Int
mismatches [] [] = 0
mismatches (a:as) (b:bs) =
    if a /= b
    then
        1 + mismatches as bs
    else
        mismatches as bs

addsevens :: Int -> [Char] -> [Char] -> [Char]
addsevens 0 f _ = f
addsevens rem (f:fewer) (m:more) =
    if f == '4' && m == '7'
    then
        '7' : addsevens (rem-1) fewer more
    else
        f : addsevens rem fewer more

operations :: [Char] -> [Char] -> Int
operations as bs =
    difference + (div swaps 2)
      where difference = abs $ (countsev as) - (countsev bs)
            swaps = mismatches (addsevens difference left right) right
                where (left, right) = if countsev as < countsev bs
                                      then (as, bs) else (bs, as)

main = do
    as <- getLine
    bs <- getLine
    putStrLn $ show $ operations as bs

import Debug.Trace

getAns a b = max n m
  where unequal = filter (\(x, y) -> x /= y) $ zip a b
        n = length $ filter (\(x, y) -> x == '7') unequal
        m = length $ filter (\(x, y) -> x == '4') unequal

main = do
  a <- getLine
  b <- getLine
  putStrLn $ show $ getAns a b

import Data.List
import Control.Applicative

main = do a <- map (read.return) <$> getLine
          b <- map (read.return) <$> getLine
          print $ solve a b

solve :: [Int] -> [Int] -> Int
solve a b
  | la4 == lb4 = div n 2
  | otherwise  = (d+) $ div (n-d) 2
   where (a4,a7) = partition (4==) a
         (b4,b7) = partition (4==) b
         la4 = length a4
         lb4 = length b4
         d = abs $ la4 - lb4
         n = length $ filter id $ zipWith (/=) a b

diff [] _ _ = 0
diff (x:xs) (y:ys) c = if x==c && x/=y then 1 + diff xs ys c
						  		        else diff xs ys c
ans x y = let
			f = diff x y '4'
			s = diff x y '7'
		  in
		    f + s - min f s
main = do
		x <- getLine
		y <- getLine
		putStrLn $ show $ ans x y

diff4 [] _ = 0
diff4 (x:xs) (y:ys) = if x=='4' && x/=y then 1 + diff4 xs ys
						  		        else diff4 xs ys
diff7 [] _ = 0
diff7 (x:xs) (y:ys) = if x=='7' && x/=y then 1 + diff7 xs ys
						  		        else diff7 xs ys
ans x y = diff4 x y + diff7 x y - min (diff4 x y) (diff7 x y)
main = do
		x <- getLine
		y <- getLine
		putStrLn $ show $ ans x y

solve::String->String->Int
solve a b
    | a == []                 = 0
    | head a == head b        = solve (tail a) (tail b)
    | length a == 1           = 1
    | head a == b!!1 && head b == a!!1 = 1+(solve (tail.tail$a) (tail.tail$b))
    | a /= b                   = 1+solve (tail a) (tail b)

main=do
    a<-getLine
    b<-getLine
    putStrLn.show.solve a$b

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
{-# OPTIONS_GHC -O2 #-}

import Data.List
import Data.Maybe
import Data.Char
import Data.Array.IArray
import Data.Array.Unboxed (UArray)
import Data.Int
import Data.Ratio
import Data.Bits
import Data.Function
import Data.Ord
--import Control.Monad.State
import Control.Monad
import Control.Applicative
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Sequence (Seq, (<|), (|>), (><), ViewL(..), ViewR(..))
import qualified Data.Sequence as Seq
import qualified Data.Foldable as F
import Data.Graph

parseInput = do
    a <- readString
    b <- readString
    return (BS.unpack a, BS.unpack b)
  where
    readInt = state $ fromJust . BS.readInt . BS.dropWhile isSpace
    readInteger = state $ fromJust . BS.readInteger . BS.dropWhile isSpace
    readString = state $ BS.span (not . isSpace) . BS.dropWhile isSpace
    readLine = state $ BS.span (not . isEoln) . BS.dropWhile isEoln
    isEoln ch = ch == '\r' || ch == '\n'

main = print =<< solve . evalState parseInput <$> BS.getContents

solve (x, y) = go x y
  where
    go [] [] = 0
    go (x:xs) (y:ys) | x == y = go xs ys
    go [x] [y] = 1
    go (x0:x:xs) (_:y:ys)
        | x == y    = go (x:xs) (y:ys) + 1
        | x0 == x   = go (x:xs) (y:ys) + 1
        | otherwise = go xs ys + 1 -- swap
----------------------------------------------------------------------
----------------------------------------------------------------------
----------------------------------------------------------------------

class (Monad m) => MonadState s m | m -> s where
	get :: m s
	put :: s -> m ()

modify :: (MonadState s m) => (s -> s) -> m ()
modify f = do
	s <- get
	put (f s)

gets :: (MonadState s m) => (s -> a) -> m a
gets f = do
	s <- get
	return (f s)

newtype State s a = State { runState :: s -> (a, s) }

instance Functor (State s) where
	fmap f m = State $ \s -> let
		(a, s') = runState m s
		in (f a, s')

instance Applicative (State s) where
    pure = return
    (<*>) = ap

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

instance MonadState s (State s) where
	get   = State $ \s -> (s, s)
	put s = State $ \_ -> ((), s)

evalState :: State s a -> s -> a
evalState m s = fst (runState m s)

execState :: State s a -> s -> s
execState m s = snd (runState m s)

mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
mapState f m = State $ f . runState m

withState :: (s -> s) -> State s a -> State s a
withState f m = State $ runState m . f

state = State


import Data.Maybe
import Data.Function
import Data.List
import qualified Data.HashMap.Strict as M

main = interact $ unlines . parse . tail . lines

type MM = M.HashMap String [String]

parse ls = let
    lss = map words ls :: [[String]]
    m = M.toList $ foldl (\m (n:_:ns) ->
                M.insert n (ns++M.lookupDefault [] n m) m) M.empty lss
    m' = map ((uncurry sol).(\(n,ns)->(n,sortBy (compare `on` length) ns))) m
    m'' = map (\(n,ns)-> intercalate " " (n:(show $ length ns):ns)) m'
  in (show$ length m''):m''

sol nn [] = (nn, [])
sol nn (n:ns) = let
    (_,ns') = sol nn ns
    nns = case find (\n'-> n `isSuffixOf` n') ns' of
              Just _ -> ns'
              Nothing -> n : ns'
  in (nn, nns)
--------------------------------------------------------------------------------
groupOn :: Int -> [a] -> [[a]]
groupOn _ [] = []
groupOn n xs = let (sts, nds) = splitAt n xs in sts : groupOn n nds

fromBool :: Num a => Bool -> a
fromBool b = if b then 1 else 0

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

swrt :: Ord a => (a, a) -> (a, a)
swrt (a, b) | compare b a == LT = (b, a) | otherwise = (a, b)
--------------------------------------------------------------------------------

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

import qualified Data.ByteString as B (getLine)
import qualified Data.ByteString.Char8 as C (readInt, words, unpack, reverse, dropWhile)
import qualified Data.Maybe as M (fromJust)
import qualified Data.Char as C (isSpace)
import qualified Data.List as L (sort, nub, isPrefixOf)
import qualified Control.Monad as M (forM, forM_)
import qualified Data.Map.Strict as MP (fromListWith, map, assocs, size)

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

run (L.nub . L.sort . map reverse -> xs) = map reverse $ (last xs) : pp where
    pp = map snd $ filter (\(a, b) -> not (b `L.isPrefixOf` a)) (zip (tail xs) xs)

main = do
    (map readInt . C.words -> [n]) <- B.getLine
    (MP.map run . MP.fromListWith (++) -> mp) <- M.forM [1..n] $ \_ -> do
        (map (C.unpack . rstrip) . C.words -> name : xs) <- B.getLine
        return (name, tail xs)
    putStrLn $ show (MP.size mp)
    M.forM_ (MP.assocs mp) $ \(a, b) ->
        putStrLn $ a ++ " " ++ show (length b) ++ " " ++ unwords b

module Main where
import qualified Data.ByteString.Char8 as B
import Control.Monad
import Control.Monad.Trans.State.Lazy
import qualified Data.Map as M
import qualified Data.Set as S

main = B.interact exec
exec = evalState app . B.words
app = do
  n <- poi
  dir <- replicateM n $ do
    name <- pop
    k <- poi
    ts <- replicateM k pop
    return (name, ts)
  let r = solve dir
  return $ B.unlines $ ((B.pack $ show (length r)):) $ map (\(na, ts) -> B.unwords $ [na, B.pack $ show (length ts)] ++ ts) r
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap (maybe undefined fst . B.readInt) pop

solve dir
  = map (\(n, ts0) -> (n, map (B.reverse . fst) $ filter (\(c, p) -> not $ c `B.isPrefixOf` p) $ (\ts -> zip ts (B.pack "":ts)) $ S.toDescList ts0))
  $ M.assocs
  $ M.fromListWith S.union $ map (\(n, ts) -> (n, S.fromList $ map B.reverse ts)) dir

import Data.List
import Control.Monad
import qualified Data.Map as M

readData :: IO (String, [String])
readData = do
    line <- getLine
    let ws = words line
    return (head ws, drop 2 ws)

readInt :: IO Int
readInt = read `fmap` getLine

printVal :: (String, [String]) -> IO ()
printVal (a, ls) = do
    let start = a ++ " " ++ show (length ls)
    let res = intercalate " " ls
    putStrLn (start ++ " " ++ res)

main :: IO ()
main = do
    n <- readInt
    ls <- replicateM n readData
    let friends = (M.fromListWith (++) ls) :: M.Map String [String]
    let friends' = M.map (\l -> let l' = nub l in filter (\x-> all (\y -> x == y || not (x `isSuffixOf` y)) l') l') friends
    let ls = M.toList friends'
    print (length ls)
    mapM_ printVal ls

module Main where
import qualified Data.ByteString.Char8 as B
import Control.Monad
import Control.Monad.Trans.State.Lazy
import qualified Data.Map as M
import qualified Data.Set as S
import Data.List
import Data.Function

main = B.interact exec
exec = evalState app . B.words
app = do
  n <- poi
  dir <- replicateM n $ do
    name <- pop
    k <- poi
    ts <- replicateM k pop
    return (name, ts)
  let r = solve dir
  return $ B.unlines $ ((B.pack $ show (length r)):) $ map (\(na, ts) -> B.unwords $ [na, B.pack $ show (length ts)] ++ ts) r
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap (maybe undefined fst . B.readInt) pop

solve dir = map (\(n, ts) -> (n, map (B.reverse . maximumBy (compare `on` B.length)) $ groupBy B.isPrefixOf $ S.toList ts)) $ M.assocs $ M.fromListWith S.union $ map (\(n, ts) -> (n, S.fromList $ map B.reverse ts)) dir

module Main where
import qualified Data.ByteString.Char8 as B
import Control.Monad
import Control.Monad.Trans.State.Lazy
import qualified Data.Map as M
import qualified Data.Set as S
import Data.List

main = B.interact exec
exec = evalState app . B.words
app = do
  n <- poi
  dir <- replicateM n $ do
    name <- pop
    k <- poi
    ts <- replicateM k pop
    return (name, ts)
  let r = solve dir
  return $ B.unlines $ ((B.pack $ show (length r)):) $ map (\(na, ts) -> B.unwords $ [na, B.pack $ show (length ts)] ++ ts) r
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap (maybe undefined fst . B.readInt) pop

solve dir = map (\(n, ts) -> (n, map (B.reverse .  last) $ groupBy B.isPrefixOf $ S.toList ts)) $ M.assocs $ M.fromListWith S.union $ map (\(n, ts) -> (n, S.fromList $ map B.reverse ts)) dir

module Main where
import qualified Data.ByteString.Char8 as B
import Control.Monad
import Control.Monad.Trans.State.Lazy
import qualified Data.Map as M
import qualified Data.Set as S

main = B.interact exec
exec = evalState app . B.words
app = do
  n <- poi
  dir <- replicateM n $ do
    name <- pop
    k <- poi
    ts <- replicateM k pop
    return (name, ts)
  let r = solve dir
  return $ B.unlines $ ((B.pack $ show (length r)):) $ map (\(na, ts) -> B.unwords $ [na, B.pack $ show (length ts)] ++ ts) r
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap (maybe undefined fst . B.readInt) pop

solve dir
  = map (\(n, ts0) -> (n, map fst $ filter (\(c, p) -> not $ c `B.isPrefixOf` p) $ (\ts -> zip ts (B.pack "":ts)) $ S.toDescList ts0))
  $ M.assocs
  $ M.fromListWith S.union $ map (\(n, ts) -> (n, S.fromList $ map B.reverse ts)) dir

import Data.List
import Control.Monad
import qualified Data.Map as M

readData :: IO (String, [String])
readData = do
    line <- getLine
    let ws = words line
    return (head ws, drop 2 ws)

readInt :: IO Int
readInt = read `fmap` getLine

printVal :: (String, [String]) -> IO ()
printVal (a, ls) = do
    let start = a ++ " " ++ show (length ls)
    let res = intercalate " " ls
    putStrLn (start ++ " " ++ res)

main :: IO ()
main = do
    n <- readInt
    ls <- replicateM n readData
    let friends = (M.fromListWith (++) ls) :: M.Map String [String]
    let friends' = M.map (\l -> let l' = nub l in filter (\x-> all (\y -> x == y || not (x `isSuffixOf` y)) l') l') friends
    let ls = M.toList friends'
    mapM_ printVal ls


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

main :: IO ()
main = do
    [n, px, py] <- map read . words <$> getLine :: IO [Int64]
    ps          <- map (\[x, y] -> (x - fromIntegral px, y - fromIntegral py))
        <$> replicateM (fromIntegral n) (map (fromIntegral . read) . words <$> getLine)
    let maxDis = maximum $ map (uncurry dis) ps
        minDis = minimum $ zipWith (curry getMinDis) ps (tail $ cycle ps)
    print $ pi * (maxDis - minDis)

dis :: Double -> Double -> Double
dis x y = x ^ 2 + y ^ 2

getMinDis ((x, y), (x', y'))
    | lambda <= 0 = dis x y
    | lambda >= 1 = dis x' y'
    | otherwise   = dis (x + lambda * (x' - x)) (y + lambda * (y' - y))
    where lambda = ((x - x') * x + (y - y') * y) / dis (x' - x) (y' - y)

module Main where

import Control.Monad
import Control.Monad.State
import Data.Maybe (fromJust)
import Text.Printf (printf)
import qualified Data.ByteString.Lazy.Char8 as L

type Point = (Double, Double)

add, sub :: Point -> Point -> Point
add (a, b) (u, v) = (a + u, b + v)
sub (a, b) (u, v) = (a - u, b - v)

scale :: Point -> Double -> Point
scale (a, b) s = (a * s, b * s)

distance :: Point -> Double
distance (a, b) = sqrt $ a * a + b * b

dot :: Point -> Point -> Double
dot (a, b) (u, v) = a * u + b * v

projection :: Point -> Point -> Point -> Point
projection p a b | offset < 0  = a
                 | offset > sl = b
                 | otherwise   = a `add` (ba `scale` (offset / sl))
    where ba = sub b a
          pa = sub p a
          sl = distance ba

          offset = (dot pa ba) / sl

getMaxDist :: Point -> [Point] -> Double
getMaxDist p = maximum . map (distance . sub p)

getMinDist :: Point -> [Point] -> Double
getMinDist p ps = minimum $ zipWith distToSegment ps (tail ps ++ [head ps])
    where distToSegment a b =  distance $ p `sub` q
              where q = projection p a b

solve :: Point -> [Point] -> Double
solve p ps = pi * (hi - lo) * (hi + lo)
    where lo = getMinDist p ps
          hi = getMaxDist p ps

test0 = ((0, 0), [(0, 1), (-1, 2), (1, 2)])
test1 = ((1, -1), [(0, 0), (1, 2), (2, 0), (1, 1)])
runTests = map (uncurry solve) [test0, test1]

type Tokenizer = State [L.ByteString]

nextInt :: Tokenizer Int
nextInt = state $ \(s:ss) -> (fst . fromJust $ L.readInt s, ss)

nextDouble :: Tokenizer Double
nextDouble = liftM fromIntegral nextInt

nextPoint :: Tokenizer Point
nextPoint = liftM2 (,) nextDouble nextDouble

go :: Tokenizer Double
go = do
  n  <- nextInt
  p  <- nextPoint
  ps <- replicateM n nextPoint
  return $ solve p ps

main :: IO ()
main = do
  input <- liftM L.words L.getContents
  let result = evalState go input
  printf "%.6f\n" result

import           Control.Monad
import           Data.List
import           Control.Arrow

main :: IO ()
main = do
    [n, px, py] <- map read . words <$> getLine
    ps          <- replicateM n (map read . words <$> getLine)
    let (minDis, maxDis) =
            (minimum &&& maximum) $ map (\[x, y] -> (px - x) ^ 2 + (py - y) ^ 2) ps
    print $ pi * fromIntegral (maxDis - minDis)

import           Control.Monad
import           Data.List
import           Control.Arrow

main :: IO ()
main = do
    [n, px, py] <- map read . words <$> getLine
    ps          <- map (\[x, y] -> (x - px, y - py))
        <$> replicateM n (map read . words <$> getLine)
    let dis x y = fromIntegral $ x ^ 2 + y ^ 2
        maxDis = fromIntegral $ maximum $ map (\(x, y) -> x ^ 2 + y ^ 2) ps
        minDis =
            minimum $ zipWith
                (curry
                    (\((x, y), (x', y')) -> if dis x y == dis x' y'
                        then fromIntegral ((x' * y - y' * x) ^ 2) / dis (x' - x) (y' - y)
                        else min (dis x y) (dis x' y')
                    )
                )
                ps
                (tail $ cycle ps) :: Double
    print (minDis, maxDis)
    print $ pi * (maxDis - minDis)

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

main :: IO ()
main = do
    [n, px, py] <- map read . words <$> getLine :: IO [Int64]
    ps          <- map (\[x, y] -> (x - px, y - py))
        <$> replicateM (fromIntegral n) (map (fromIntegral . read) . words <$> getLine)
    let dis x y = fromIntegral $ x ^ 2 + y ^ 2
        maxDis = fromIntegral $ maximum $ map (\(x, y) -> x ^ 2 + y ^ 2) ps
        minDis =
            minimum $ zipWith
                (curry
                    (\((x, y), (x', y')) -> if dis x y == dis x' y'
                        then fromIntegral ((x' * y - y' * x) ^ 2) / dis (x' - x) (y' - y)
                        else min (dis x y) (dis x' y')
                    )
                )
                ps
                (tail $ cycle ps) :: Double
    print $ pi * (maxDis - minDis)

import           Control.Monad
import           Data.List
import           Control.Arrow

main :: IO ()
main = do
    [n, px, py] <- map read . words <$> getLine
    ps          <- map (\[x, y] -> (x - px, y - py))
        <$> replicateM n (map read . words <$> getLine)
    let dis x y = fromIntegral $ x ^ 2 + y ^ 2
        maxDis = fromIntegral $ maximum $ map (\(x, y) -> x ^ 2 + y ^ 2) ps
        minDis =
            minimum $ zipWith
                (curry
                    (\((x, y), (x', y')) -> if dis x y == dis x' y'
                        then fromIntegral ((x' * y - y' * x) ^ 2) / dis (x' - x) (y' - y)
                        else min (dis x y) (dis x' y')
                    )
                )
                ps
                (tail $ cycle ps) :: Float
    print (minDis, maxDis)
    print $ pi * (maxDis - minDis)

import           Control.Monad
import           Data.List
import           Control.Arrow

main :: IO ()
main = do
    [n, px, py] <- map read . words <$> getLine
    ps          <- map (\[x, y] -> (x - px, y - py))
        <$> replicateM n (map read . words <$> getLine)
    let dis x y = fromIntegral $ x ^ 2 + y ^ 2
        maxDis = fromIntegral $ maximum $ map (\(x, y) -> x ^ 2 + y ^ 2) ps
        minDis =
            minimum $ zipWith
                (curry
                    (\((x, y), (x', y')) -> if dis x y == dis x' y'
                        then fromIntegral ((x' * y - y' * x) ^ 2) / dis (x' - x) (y' - y)
                        else min (dis x y) (dis x' y')
                    )
                )
                ps
                (tail $ cycle ps) :: Double
    print $ pi * (maxDis - minDis)


main::IO()
main =
    do cs <- getContents
       (putStr.showSolve.solve.parseIn) cs

parseIn::String->(Int,[Integer])
parseIn s = (n,an)
    where
      (ns:l:_) = lines s
      n = read ns
      an = map read $ words l

showSolve ::[Integer]->String
showSolve [] = ""
showSolve [x] = show x
showSolve (x:xs) = show x ++ "\n"++  showSolve xs

pow2seq=map (\x -> 2^x) [0..]

getPlusedIndex s p = last $ takeWhile (\x -> x < s) $ map (+ p) pow2seq

updateList::[Integer]->Int->Integer->[Integer]
updateList [] _ _ = []
updateList (a:as) 0 x = (a+x):as
updateList (a:as) n x = a:(updateList as (n-1) x)

solveSeq::[Integer]->[Integer]->Int->Int->[Integer]
solveSeq _ ret _ 0 = ret
solveSeq _ ret _ 1 = ret
solveSeq l ret size n = solveSeq ln retn size (n-1)
    where
      p = size - n
      c = l!!p
      next = getPlusedIndex size p
      ln   = updateList l next c
      retn = updateList ret p c

plusReduce::[Integer]->[Integer]
plusReduce [] = []
plusReduce (x:xs) = x:(map (+x) $ plusReduce xs)

solve::(Int,[Integer])->[Integer]
solve (n,ps) = cnts
    where
      cnts = plusReduce $ solveSeq ps (take (n-1) [0,0..]) n n


import Control.Applicative
import qualified Data.ByteString.Char8 as BS
import Data.Maybe

readIntBS = fst . fromJust . BS.readInt

main = do
  [n,l,a] <- map read . words <$> getLine :: IO [Int]
  dat <- map (map readIntBS . BS.words) . BS.lines <$> BS.getContents :: IO [[Int]]

  let dat' = ([0,0] : dat) ++ [[l,0]]

  print $ sum [(j-(i+k))`div`a | ([i,k], [j,_]) <- zip dat' (tail dat')]

-- Codeforces 1059A
import Data.List

countBreaks :: Int -> [Int] -> [Int] -> Int
countBreaks breakLength startTime endTime = sum countList
    where breakList = zipWith (-) startTime endTime
          countList = map (`div` breakLength) breakList

mapStartTime :: [Int] -> Int -> [Int]
mapStartTime starts end = starts ++ [end]

mapEndTime :: [Int] -> [Int] -> [Int]
mapEndTime starts durations = 0:zipWith (+) starts durations

main :: IO ()
main = do
    [n, l, a] <- getLine >>= return.(map read::[String]->[Int]).words
    [start, duration] <-
            if n == 0 then return [[], []]
            else do getContents >>=
                        return.(map $ map read).transpose.(map words).(take n).lines :: IO [[Int]]
    let startTime = mapStartTime start l
    let endTime   = mapEndTime start duration
    putStrLn $ show $ countBreaks a startTime endTime