import Array
import Char
main = interact (ans)
ans theInput = unlines ansList where
  s:t:n0:abw0 = lines theInput
  n = read n0 ::Int
  abw = [(c2i $ x!!0,c2i $ x!!2,read(drop 4 x)::Integer)|x<-(take n abw0)]
  c2i x = ord x - ord 'a'
  table [] = array ((0,0),(25,25)) [((a,b),if a==b then 0 else 999999999)|a<-[0..25],b<-[0..25]]
  table ((a,b,w):xs) = (table xs) // [((a,b),min w ( (table xs)!(a,b) ) )]
  wf 0 = table abw
  wf (m+1) = array((0,0),(25,25)) [((a,b),min ((wf m)!(a,b)) ( ((wf m)!(a,m))+((wf m)!(m,b)) ) ) |a<-[0..25],b<-[0..25]] where
  final = wf 26
  cost t = array((0,0),(25,25)) [((x,y),foldr1 min [( (t!(x,z)) + (t!(y,z)),z )|z<-[0..25]])|x<-[0..25],y<-[0..25]]
  total = sum [fst (cf x y)|(x,y)<-zip s t]
  answord = [chr(snd (cf x y)+ord 'a') |(x,y)<-zip s t]
  cf x y = (cost final) ! (c2i x,c2i y)
  ansList = if total>999999998 || length s /= length t then ["-1"] else [show total,answord]

import Array
import Char
main = interact (ans)
ans theInput = unlines ansList where
  s:t:n0:abw0 = lines theInput
  n = read n0 ::Int
  abw = [(c2i $ x!!0,c2i $ x!!2,read(drop 4 x)::Integer)|x<-(take n abw0)]
  c2i x = ord x - ord 'a'
  table [] = array ((0,0),(25,25)) [((a,b),if a==b then 0 else 999999999)|a<-[0..25],b<-[0..25]]
  table ((a,b,w):xs) = (table xs) // [((a,b),min w ( (table xs)!(a,b) ) )]
  wf 0 = table abw
  wf (m+1) = array((0,0),(25,25)) [((a,b),min ((wf m)!(a,b)) ( ((wf m)!(a,m))+((wf m)!(m,b)) ) ) |a<-[0..25],b<-[0..25]]
  final = wf 26
  cost t = array((0,0),(25,25)) [((x,y),foldr1 min [( (t!(x,z)) + (t!(y,z)),z )|z<-[0..25]])|x<-[0..25],y<-[0..25]]
  total = sum [fst (cf x y)|(x,y)<-zip s t]
  answord = [chr(snd (cf x y)+ord 'a') |(x,y)<-zip s t]
  cf x y = (cost final) ! (c2i x,c2i y)
  ansList = if total>999999998 || length s /= length t then ["-1"] else [show total,answord]

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, ForeignFunctionInterface  #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
-- import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.IORef
import Data.Int
import System.Exit
import Text.Printf
import qualified Foreign as F
import qualified Foreign.C as F

foreign import ccall unsafe "stdio.h printf"
  c_printf_I64d :: F.CString -> F.CLLong -> IO ()

foreign import ccall unsafe "stdio.h printf"
  c_printf_s :: F.CString -> F.CString -> IO ()

inf :: Int64
inf = 10 ^ 16

{-# SPECIALIZE for_ :: Char -> Char -> (Char -> IO ()) -> IO () #-}
{-# SPECIALIZE for_ :: Int -> Int -> (Int -> IO ()) -> IO () #-}
for_ :: (Monad m, Ord a, Enum a) => a -> a -> (a -> m ()) -> m ()
for_ i n f = loop i where
  loop i | i <= n    = f i >> loop (succ i)
         | otherwise = return ()

main :: IO ()
main = do
  let exit = print (-1) >> exitSuccess
      conv = fromIntegral . fst . fromJust . BS.readInt
  table <- newArray (('a', 'a'), ('z', 'z')) inf :: IO (IOUArray (Char, Char) Int64)
  F.withCString "%I64d\n" $ \fmt_I64d -> do
    F.withCString "%s\n" $ \fmt_s -> do
      for_ 'a' 'z' $ \c -> do
        writeArray table (c, c) 0
      s1 <- BS.filter (/= '\r') <$> BS.getLine
      s2 <- BS.filter (/= '\r') <$> BS.getLine
      when (BS.length s1 /= BS.length s2) $ exit
      n <- readLn
      for_ 1 n $ \i -> do
        from : to : s : _ <- BS.words <$> BS.getLine
        let idx = (BS.head from, BS.head to)
        v <- readArray table idx
        writeArray table idx $ min (conv s) v
      for_ 'a' 'z' $ \k -> do
        for_ 'a' 'z' $ \i -> do
          for_ 'a' 'z' $ \j -> do
            v  <- readArray table (i, j)
            v1 <- readArray table (i, k)
            v2 <- readArray table (k, j)
            when (v1 + v2 < v) $ do
              writeArray table (i, j) $ v1 + v2
      -- getAssocs table >>= print . filter ((/= inf) . snd)
      r <- newIORef 0 :: IO (IORef Int64)
      buf <- F.mallocArray0 101000 :: IO F.CString
      for_ 0 (BS.length s1 - 1) $ \i -> do
        let c1 = BS.index s1 i
            c2 = BS.index s2 i
            findMin = loop 'a' ('\0', inf) where
              loop to acc@(c, v)
                | 'z' < to  = return acc
                | otherwise = do
                    v1 <- readArray table (c1, to)
                    v2 <- readArray table (c2, to)
                    -- printf "%s\n" (show (c1, c2, to))
                    loop (succ to) $ if v1 + v2 < v then (to, v1 + v2) else acc
        (c, v) <- findMin
        when (c == '\0') $ exit
        modifyIORef r $ (+ v)
        F.poke (buf `F.advancePtr` i) (toEnum . fromEnum $ c)
      F.poke (buf `F.advancePtr` (BS.length s1)) (toEnum . fromEnum $ '\0')
      readIORef r >>= c_printf_I64d fmt_I64d . fromIntegral
      c_printf_s fmt_s buf
      F.free buf

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, ForeignFunctionInterface  #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
-- import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.IORef
import Data.Int
import System.Exit
import Text.Printf
import qualified Foreign as F
import qualified Foreign.C as F

foreign import ccall unsafe "stdio.h printf"
  c_printf_I64d :: F.CString -> F.CLLong -> IO ()

foreign import ccall unsafe "stdio.h printf"
  c_printf_s :: F.CString -> F.CString -> IO ()

inf :: Int64
inf = 10 ^ 16

{-# SPECIALIZE for_ :: Char -> Char -> (Char -> IO ()) -> IO () #-}
{-# SPECIALIZE for_ :: Int -> Int -> (Int -> IO ()) -> IO () #-}
for_ :: (Monad m, Ord a, Enum a) => a -> a -> (a -> m ()) -> m ()
for_ i n f = loop i where
  loop i | i <= n    = f i >> loop (succ i)
         | otherwise = return ()

main :: IO ()
main = do
  let exit = print (-1) >> exitSuccess
      conv = fromIntegral . fst . fromJust . BS.readInt
  table <- newArray (('a', 'a'), ('z', 'z')) inf :: IO (IOUArray (Char, Char) Int64)
  F.withCString "%I64d\n" $ \fmt_I64d -> do
    F.withCString "%s\n" $ \fmt_s -> do
      for_ 'a' 'z' $ \c -> do
        writeArray table (c, c) 0
      s1 <- BS.filter (/= '\r') <$> BS.getLine
      s2 <- BS.filter (/= '\r') <$> BS.getLine
      -- s1 <- BS.getLine
      -- s2 <- BS.getLine
      when (BS.length s1 /= BS.length s2) $ exit
      n <- readLn
      for_ 1 n $ \i -> do
        from : to : s : _ <- BS.words <$> BS.getLine
        let idx = (BS.head from, BS.head to)
        v <- readArray table idx
        writeArray table idx $ min (conv s) v
      for_ 'a' 'z' $ \k -> do
        for_ 'a' 'z' $ \i -> do
          for_ 'a' 'z' $ \j -> do
            v  <- readArray table (i, j)
            v1 <- readArray table (i, k)
            v2 <- readArray table (k, j)
            when (v1 + v2 < v) $ do
              writeArray table (i, j) $ v1 + v2
      -- getAssocs table >>= print . filter ((/= inf) . snd)
      r <- newIORef 0 :: IO (IORef Int64)
      buf <- F.mallocArray0 101000 :: IO F.CString
      for_ 0 (BS.length s1 - 1) $ \i -> do
        let c1 = BS.index s1 i
            c2 = BS.index s2 i
            findMin = loop 'a' ('\0', inf) where
              loop to acc@(c, v)
                | 'z' < to  = return acc
                | otherwise = do
                    v1 <- readArray table (c1, to)
                    v2 <- readArray table (c2, to)
                    -- printf "%s\n" (show (c1, c2, to))
                    loop (succ to) $ if v1 + v2 < v then (to, v1 + v2) else acc
        (c, v) <- findMin
        when (c == '\0') $ exit
        modifyIORef r $ (+ v)
        F.poke (buf `F.advancePtr` i) (toEnum . fromEnum $ c)
      F.poke (buf `F.advancePtr` (BS.length s1)) (toEnum . fromEnum $ '\0')
      readIORef r >>= c_printf_I64d fmt_I64d . fromIntegral
      c_printf_s fmt_s buf
      F.free buf

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

import Array
import Char
main = interact (ans)
ans theInput = unlines ansList where
  s:t:n0:abw0 = lines theInput
  n = read n0 ::Int
  abw = [(c2i $ x!!0,c2i $ x!!2,read(drop 4 x)::Int)|x<-(take n abw0)]
  c2i x = ord x - ord 'a'
  table [] = array ((0,0),(25,25)) [((a,b),if a==b then 0 else 9999)|a<-[0..25],b<-[0..25]]
  table ((a,b,w):xs) = (table xs) // [((a,b),min w ((table xs)!(a,b)))]
  wf 0 = table abw
  wf (m+1) = array((0,0),(25,25))
    [((a,b),foldr min ((wf m)!(a,b)) [ ((wf m)!(a,m)+(wf m)!(m,b)) , 9999] )|a<-[0..25],b<-[0..25]]
  final = wf 26
  cost t = array((0,0),(25,25)) [((x,y),foldr min (9999,-1) [(t!(x,z)+t!(y,z),z)|z<-[0..25]])|x<-[0..25],y<-[0..25]]
  total = sum [fst (cf x y)|(x,y)<-zip s t]
  answord = [chr(snd (cf x y)+ord 'a') |(x,y)<-zip s t]
  cf x y = (cost final) ! (c2i x,c2i y)
  ansList = if total>9998 || length s /= length t then ["-1"] else [show total,answord]

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
-- import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Data.Map as Map
-- import qualified Data.Set as Set
-- import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.Array.Unboxed
import System.Exit

main :: IO ()
main = do
  let readData :: IO [Int]
      readData = map read . words <$> getLine
      -- readData = map (fst . fromJust . BS.readInt) . BS.words <$> BS.getLine
      exit = print (-1) >> exitSuccess
  s1 <- getLine
  s2 <- getLine
  when (length s1 /= length s2) $  exit
  n <- readLn
  cs <- T.for [1 .. n] $ \i -> do
    from : to : v: _ <- words <$> getLine
    return (head from, Map.singleton (head to) (read v :: Int))
  let mp = Map.fromListWith (Map.unionWith min) cs
      bnds = (('a', 'a'), ('z', 'z'))
  table <- newArray bnds maxBound :: IO (IOArray (Char, Char) Int)
  F.for_ (zip ['a' .. 'z'] ['a' .. 'z']) $ \idx -> do
    writeArray table idx 0
  let fill from cost now = F.for_ (Map.lookup now mp) $ \mp' -> do
        F.for_ (Map.toList mp') $ \(to, new) -> do
          old <- readArray table (now, to)
          when (old == maxBound || new < old) $ do
            writeArray table (now, to) new
            let new' = cost + new
            old' <- readArray table (from, to)
            when (old' == maxBound || new' < old') $ do
              writeArray table (from, to) new'
            fill from new' to
  F.for_ ['a' .. 'z'] $ \c -> fill c 0 c

  let check c1 c2
        | c1 == c2  = return (c1, 0)
        | otherwise = do
            xs <- T.for ['a' .. 'z'] $ \to -> do
              v1 <- readArray table (c1, to)
              v2 <- readArray table (c2, to)
              case () of
                _ | c1 == to  -> return (to, v2)
                  | c2 == to  -> return (to, v1)
                  | otherwise -> return (to, min v1 v2)
            when (null xs) $ exit
            let (c, cost) = minimumBy (comparing snd) xs
            if cost == maxBound
              then exit
              else do
                return (c, cost)
  (answer, cost) <- unzip <$> zipWithM check s1 s2
--  getAssocs table >>= printf "%s\n" . show
  print $ sum cost
  putStrLn answer

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
-- import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Data.Map as Map
-- import qualified Data.Set as Set
-- import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.Array.Unboxed
import System.Exit

inf :: Integer
inf = 10 ^ 20

main :: IO ()
main = do
  let readData :: IO [Int]
      readData = map read . words <$> getLine
      -- readData = map (fst . fromJust . BS.readInt) . BS.words <$> BS.getLine
      exit = print (-1) >> exitSuccess
  s1 <- getLine
  s2 <- getLine
  when (length s1 /= length s2) $  exit
  n <- readLn
  cs <- T.for [1 .. n] $ \i -> do
    from : to : v: _ <- words <$> getLine
    return (head from, Map.singleton (head to) (read v :: Integer))
  let mp = Map.fromListWith (Map.unionWith min) cs
      bnds = (('a', 'a'), ('z', 'z'))
  table <- newArray bnds inf :: IO (IOArray (Char, Char) Integer)
  F.for_ (zip ['a' .. 'z'] ['a' .. 'z']) $ \idx -> do
    writeArray table idx 0
  let fill from cost now = F.for_ (Map.lookup now mp) $ \mp' -> do
        F.for_ (Map.toList mp') $ \(to, new) -> do
          old <- readArray table (now, to)
          when (old == inf || new < old) $ do
            writeArray table (now, to) new
            let new' = cost + new
            old' <- readArray table (from, to)
            when (old' == inf || new' < old') $ do
              writeArray table (from, to) new'
            fill from new' to
  F.for_ ['a' .. 'z'] $ \c -> fill c 0 c
  let check c1 c2
        | c1 == c2  = return (c1, 0)
        | otherwise = do
            xs <- T.for ['a' .. 'z'] $ \to -> do
              v1 <- readArray table (c1, to)
              v2 <- readArray table (c2, to)
              case () of
                _ | c1 == to  -> return (to, v2)
                  | c2 == to  -> return (to, v1)
                  | otherwise -> return (to, v1 + v2)
            when (null xs) $ exit
            let (c, cost) = minimumBy (comparing snd) xs
            if cost == inf
              then exit
              else do
                return (c, cost)
  (answer, cost) <- unzip <$> zipWithM check s1 s2
--  getAssocs table >>= printf "%s\n" . show
  print $ sum cost
  putStrLn answer

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, ForeignFunctionInterface  #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
-- import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.IORef
import Data.Int
import System.Exit
import Text.Printf
import qualified Foreign as F
import qualified Foreign.C as F

foreign import ccall unsafe "stdio.h puts"
  puts :: F.CString -> IO ()

inf :: Int64
inf = 10 ^ 16

{-# SPECIALIZE for_ :: Char -> Char -> (Char -> IO ()) -> IO () #-}
{-# SPECIALIZE for_ :: Int -> Int -> (Int -> IO ()) -> IO () #-}
for_ :: (Monad m, Ord a, Enum a) => a -> a -> (a -> m ()) -> m ()
for_ i n f = loop i where
  loop i | i <= n    = f i >> loop (succ i)
         | otherwise = return ()

main :: IO ()
main = do
  let exit = print (-1) >> exitSuccess
      conv = fromIntegral . fst . fromJust . BS.readInt
  table <- newArray (('a', 'a'), ('z', 'z')) inf :: IO (IOUArray (Char, Char) Int64)
  for_ 'a' 'z' $ \c -> do
    writeArray table (c, c) 0
  s1 <- BS.filter (/= '\r') <$> BS.getLine
  s2 <- BS.filter (/= '\r') <$> BS.getLine
  when (BS.length s1 /= BS.length s2) $ exit
  n <- readLn
  for_ 1 n $ \i -> do
    from : to : s : _ <- BS.words <$> BS.getLine
    let idx = (BS.head from, BS.head to)
    v <- readArray table idx
    writeArray table idx $ min (conv s) v
  for_ 'a' 'z' $ \k -> do
    for_ 'a' 'z' $ \i -> do
      for_ 'a' 'z' $ \j -> do
        v  <- readArray table (i, j)
        v1 <- readArray table (i, k)
        v2 <- readArray table (k, j)
        when (v1 + v2 < v) $ do
          writeArray table (i, j) $ v1 + v2
  -- getAssocs table >>= print . filter ((/= inf) . snd)
  r <- newIORef 0 :: IO (IORef Int64)
  buf <- F.mallocArray0 101000 :: IO F.CString
  for_ 0 (BS.length s1 - 1) $ \i -> do
    let c1 = BS.index s1 i
        c2 = BS.index s2 i
        findMin = loop 'a' ('\0', inf) where
          loop to acc@(c, v)
            | 'z' < to  = return acc
            | otherwise = do
                v1 <- readArray table (c1, to)
                v2 <- readArray table (c2, to)
                -- printf "%s\n" (show (c1, c2, to))
                loop (succ to) $ if v1 + v2 < v then (to, v1 + v2) else acc
    (c, v) <- findMin
    when (c == '\0') $ exit
    modifyIORef r $ (+ v)
    F.poke (buf `F.advancePtr` i) (toEnum . fromEnum $ c)
  F.poke (buf `F.advancePtr` (BS.length s1)) (toEnum . fromEnum $ '\0')
  readIORef r >>= print
  puts buf
  F.free buf

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
-- import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Data.Map as Map
-- import qualified Data.Set as Set
-- import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.Array.Unboxed
import System.Exit

inf :: Integer
inf = 10 ^ 20

main :: IO ()
main = do
  let readData :: IO [Int]
      readData = map read . words <$> getLine
      -- readData = map (fst . fromJust . BS.readInt) . BS.words <$> BS.getLine
      exit = print (-1) >> exitSuccess
  s1 <- getLine
  s2 <- getLine
  when (length s1 /= length s2) $  exit
  n <- readLn
  cs <- T.for [1 .. n] $ \i -> do
    from : to : v: _ <- words <$> getLine
    return (head from, Map.singleton (head to) (read v :: Integer))
  let mp = Map.fromListWith (Map.unionWith min) cs
      bnds = (('a', 'a'), ('z', 'z'))
  table <- newArray bnds inf :: IO (IOArray (Char, Char) Integer)
  F.for_ (zip ['a' .. 'z'] ['a' .. 'z']) $ \idx -> do
    writeArray table idx 0
  let fill from cost now = F.for_ (Map.lookup now mp) $ \mp' -> do
        F.for_ (Map.toList mp') $ \(to, new) -> do
          old <- readArray table (now, to)
          when (old == inf || new < old) $ do
            writeArray table (now, to) new
            let new' = cost + new
            old' <- readArray table (from, to)
            when (old' == inf || new' < old') $ do
              writeArray table (from, to) new'
            fill from new' to
  F.for_ ['a' .. 'z'] $ \c -> fill c 0 c
  let check c1 c2
        | c1 == c2  = return (c1, 0)
        | otherwise = do
            xs <- T.for ['a' .. 'z'] $ \to -> do
              v1 <- readArray table (c1, to)
              v2 <- readArray table (c2, to)
              case () of
                _ | c1 == to  -> return (to, v2)
                  | c2 == to  -> return (to, v1)
                  | otherwise -> return (to, min v1 v2)
            when (null xs) $ exit
            let (c, cost) = minimumBy (comparing snd) xs
            if cost == inf
              then exit
              else do
                return (c, cost)
  (answer, cost) <- unzip <$> zipWithM check s1 s2
--  getAssocs table >>= printf "%s\n" . show
  print $ sum cost
  putStrLn answer

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
-- import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Data.Map as Map
-- import qualified Data.Set as Set
-- import qualified Data.ByteString.Char8 as BS
import Text.Printf
import Data.Array.IO
import Data.Array.Unboxed
import System.Exit

main :: IO ()
main = do
  let readData :: IO [Int]
      readData = map read . words <$> getLine
      -- readData = map (fst . fromJust . BS.readInt) . BS.words <$> BS.getLine
      exit = print (-1) >> exitSuccess
  s1 <- getLine
  s2 <- getLine
  when (length s1 /= length s2) $  exit
  n <- readLn
  cs <- T.for [1 .. n] $ \i -> do
    from : to : v: _ <- words <$> getLine
    return (head from, Map.singleton (head to) (read v :: Int))
  let mp = Map.fromListWith (Map.unionWith min) cs
      bnds = (('a', 'a'), ('z', 'z'))
  table <- newArray bnds maxBound :: IO (IOArray (Char, Char) Int)
--  F.for_ (zip ['a' .. 'z'] ['a' .. 'z']) $ \idx -> do
--    writeArray table idx 0
  let fill from cost now = F.for_ (Map.lookup now mp) $ \mp' -> do
        F.for_ (Map.toList mp') $ \(to, new) -> do
          old <- readArray table (now, to)
          when (old == maxBound || new < old) $ do
            writeArray table (now, to) new
            let new' = cost + new
            old' <- readArray table (from, to)
            when (old' == maxBound || new' < old') $ do
              writeArray table (from, to) new'
            fill from new' to
  F.for_ ['a' .. 'z'] $ \c -> fill c 0 c
  let check c1 c2
        | c1 == c2  = return (c1, 0)
        | otherwise = do
            xs <- T.for ['a' .. 'z'] $ \to -> do
              v1 <- readArray table (c1, to)
              v2 <- readArray table (c2, to)
              case () of
                _ | c1 == to  -> return (to, v2)
                  | c2 == to  -> return (to, v1)
                  | otherwise -> return (to, min v1 v2)
            when (null xs) $ exit
            let (c, cost) = minimumBy (comparing snd) xs
            if cost == maxBound
              then exit
              else do
                return (c, cost)
  (answer, cost) <- unzip <$> zipWithM check s1 s2
--  getAssocs table >>= printf "%s\n" . show
  print $ sum cost
  putStrLn answer

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -cpp #-}
{-# OPTIONS_GHC -funbox-strict-fields -fexcess-precision -monly-3-regs #-}
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-}

import Control.Applicative
import Control.Monad
-- import Control.Arrow
import Data.List
-- import Data.Maybe
import Data.Ord
import Data.Char
-- import Data.Function
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Data.Map as Map
-- import qualified Data.Set as Set
-- import qualified Data.ByteString.Char8 as BS
import Text.Printf
import System.Exit

main :: IO ()
main = do
  let readData :: IO [Int]
      readData = map read . words <$> getLine
      -- readData = map (fst . fromJust . BS.readInt) . BS.words <$> BS.getLine
      exit = print (-1) >> exitSuccess
  s1 <- getLine
  s2 <- getLine
  when (length s1 /= length s2) $ exit
  n <- readLn
  init <- fmap (Map.fromListWith min) . T.for [1 .. n] $ \i -> do
    from : to : v: _ <- words <$> getLine
    return ((head from, head to), (read v :: Integer))
  let mp = foldl check init ['a' .. 'z']
      check acc k = foldl f acc [(i, j) | i <- ['a' .. 'z'], j <- ['a' .. 'z']]
        where f acc' (i, j) = maybe acc' g $ do
                v1 <- Map.lookup (i, k) acc'
                v2 <- Map.lookup (k, j) acc'
                return $ v1 + v2
                where g v = maybe (Map.insert (i, j) v acc') id $ do
                        v' <- Map.lookup (i, j) acc'
                        return $ if v < v'
                                   then Map.insert (i, j) v acc'
                                   else acc'
  let best c1 c2
        | c1 == c2  = return (c1, 0)
        | otherwise = do
            xs <- fmap concat . T.for ['a' .. 'z'] $ \to -> do
              return . maybe [] (return . (,) to) $ do
                case () of
                  _ | c1 == to  -> Map.lookup (c2, to) mp
                    | c2 == to  -> Map.lookup (c1, to) mp
                    | otherwise -> do
                        v1 <- Map.lookup (c1, to) mp
                        v2 <- Map.lookup (c2, to) mp
                        return $ min v1 v2
            when (null xs) $ exit
            return $ minimumBy (comparing snd) xs
  (answer, cost) <- fmap sum . unzip <$> zipWithM best s1 s2
  -- print mp
  print cost
  putStrLn answer

{-
ad
ad
6
a b 1
a e 4
b e 1
b c 2
c d 100
e d 5
-}


import Data.List
import qualified Data.ByteString.Char8 as B
import Control.Applicative

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

main = getLine >> do
  cnts <- map (pred.length).group.sort.([0..9]++).map readInt.B.words <$> B.getLine
  if cnts!!0 == 0
     then print $ -1
     else putStrLn.f.solve $ cnts

f (0:_) = "0"
f ns = ns>>=show

g cnts = do
  i<-[9,8..0]
  replicate (cnts!!i) i

del i xs = let (ys,x:zs)=splitAt i xs
           in ys++(x-1):zs

solve :: [Int] -> [Int]
solve cnts = case (`mod`3) $ sum $ zipWith (*) cnts [0..9] of
             0 -> g cnts
             1 | (x:_)<-filter((>0).(cnts!!))[1,4,7] -> g $ del x cnts
               | (x:_)<-filter((>1).(cnts!!))[2,5,8] -> g $ del x $ del x cnts
               | (x:y:_)<-filter((>0).(cnts!!))[2,5,8] -> g $ del x $ del y cnts
             2 | (x:_)<-filter((>0).(cnts!!))[2,5,8] -> g $ del x cnts
               | (x:_)<-filter((>1).(cnts!!))[1,4,7] -> g $ del x $ del x cnts
               | (x:y:_)<-filter((>0).(cnts!!))[1,4,7] -> g $ del x $ del y cnts
             _ -> [-1]

import Data.Char (intToDigit)
import Data.List (sort, delete)
extract f = filter (f . (`mod` 3))
solve :: [Int] -> Maybe [Int]
solve xs
    | 0 `notElem` xs = Nothing
    | otherwise =
        case pl `mod` 3 of
            0 -> Just $ reverse ss
            1 -> factored 1
            2 -> factored 2
    where pl = sum xs
          ss = sort xs
          ms = extract (/=0) ss
          factored h = case safeFind h ms of
                (_, Just x) -> Just $ reverse $ delete x ss
                _ -> case safeFind (3 - h) ms of
                    (Just y, Just x) -> Just $ reverse $ delete y $ delete x $ ss
                    _ -> Nothing
safeFind :: Int -> [Int] -> (Maybe Int, Maybe Int)
safeFind m ps =
    case extract (==m) ps of
        [] -> (Nothing, Nothing)
        [x] -> (Nothing, Just x)
        (y:x:s) -> (Just y, Just x)

parse :: Maybe [Int] -> String
parse Nothing  = "-1"
parse (Just v) = if all (==0) v then "0" else map intToDigit v

main = putStrLn.parse.solve.map read.tail.words =<< getContents

import Data.Char (intToDigit)
import Data.List (sort, delete)
extract f = filter (f . (`mod` 3))
solve :: [Int] -> Maybe [Int]
solve xs
    | 0 `notElem` xs = Nothing
    | otherwise = if md == 0 then Just ss else factored md
    where md = sum xs `mod` 3
          ss = sort xs
          ms = extract (/=0) ss
          factored h = case extract (==h) ms of
                (x:_) -> Just (delete x ss)
                _ -> case extract (==(3 - h)) ms of
                    (y:x:_) -> Just (delete y (delete x ss))
                    _ -> Nothing
parse :: Maybe [Int] -> String
parse Nothing  = "-1"
parse (Just v) = if all (==0) v then "0" else map intToDigit (reverse v)
main = putStrLn.parse.solve.map read.tail.words =<< getContents

import Data.List

solve :: [Int] -> [Int]
solve ds
    | all (/= 0) ts = []
    | all (== 0) ts = [0]
    | otherwise = reverse ts
    where r = sum ds `mod` 3
          xs = sort ds
          ps = map (\x -> filter (\y -> y `mod` 3 == x) xs) [0, 1, 2]
          ts | r == 0 = xs
             | null $ ps !! r = xs \\ (take 2 (ps !! (3 - r)))
             | otherwise = delete (ps !! r !! 0) xs

readInput :: IO [Int]
readInput = do
    contents <- getContents
    let x:xs = words contents
        ds = map read $ take (read x) xs
    return ds

showOutput :: [Int] -> IO ()
showOutput xs = do
    putStrLn $ if null xs then "-1" else concat $ map show xs

main :: IO ()
main = do
    input <- readInput
    showOutput $ solve input

import Data.List

solve :: [Int] -> [Int]
solve ds
    | all (/= 0) ts = []
    | all (== 0) ts = [0]
    | otherwise = reverse ts
    where r = sum ds `mod` 3
          xs = sort ds
          ps = map (\x -> filter (\y -> y `mod` 3 == x) xs) [0, 1, 2]
          ts | r == 0 = xs
             | null $ ps !! r = xs \\ (take 2 (ps !! (3 - r)))
             | otherwise = delete (ps !! r !! 0) xs

readInput :: IO [Int]
readInput = do
    contents <- getContents
    let n:ns = words contents
        ds = map read $ take (read n) ns
    return ds

showOutput :: [Int] -> IO ()
showOutput ds = do
    putStrLn $ if null ds then "-1" else concat $ map show ds

main :: IO ()
main = do
    input <- readInput
    showOutput $ solve input

import Data.Char (intToDigit)
import Data.List (sort, delete)
extract f = filter (f . (`mod` 3))
solve :: [Int] -> Maybe [Int]
solve xs
    | 0 `notElem` xs = Nothing
    | all (==0) xs = Just [0]
    | otherwise =
        case pl `mod` 3 of
            0 -> Just $ reverse ss
            1 -> factored 1
            2 -> factored 2
    where pl = sum xs
          ss = sort xs
          ms = extract (/=0) ss
          factored h = case safeFind h ms of
                (_, Just x) -> Just $ reverse $ delete x ss
                _ -> case safeFind (3 - h) ms of
                    (Just y, Just x) -> Just $ reverse $ delete y $ delete x $ ss
                    _ -> Nothing
safeFind :: Int -> [Int] -> (Maybe Int, Maybe Int)
safeFind m ps =
    case extract (==m) ps of
        [] -> (Nothing, Nothing)
        [x] -> (Nothing, Just x)
        (y:x:s) -> (Just y, Just x)

parse :: Maybe [Int] -> String
parse Nothing  = "-1"
parse (Just v) = map intToDigit v

main = putStrLn.parse.solve.map read.tail.words =<< getContents

import Data.List

solve :: [Int] -> [Int]
solve xs
    | all (/= 0) ts = []
    | all (== 0) ts = [0]
    | otherwise = reverse $ sort ts
    where r = sum xs `mod` 3
          ps = map (\x -> filter (\y -> y `mod` 3 == x) xs) [0, 1, 2]
          ts | r == 0 = xs
             | null $ ps !! r = xs \\ (take 2 (ps !! (3 - r)))
             | otherwise = delete (ps !! r !! 0) xs

readInput :: IO [Int]
readInput = do
    contents <- getContents
    let x:xs = words contents
        ds = map read $ take (read x) xs
    return ds

showOutput :: [Int] -> IO ()
showOutput xs = do
    putStrLn $ if null xs then "-1" else concat $ map show xs

main :: IO ()
main = do
    input <- readInput
    showOutput $ solve input


import qualified Data.ByteString.Char8 as B

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

main = B.getContents>>=putStrLn.unwords.map show.solve.zip[1..].tail.map readInt.B.words

solve :: [(Int,Int)] -> [Int]
solve ((i,x):(j,y):(k,z):rest)
  | x==y && y==z = solve ((j,y):(k,z):rest)
  | x==y = [j,k]
  | y==z || x<y && y<z || x>y && y>z = [i,j]
  | z/=x = [i,k]
  | null rest = [-1]
  | x == w = [j,k]
  | y == w = [i,j]
  | otherwise = [k,l]
   where
     (l,w) = head rest
solve _ = [-1]

-- Codeforces 252B

{-# OPTIONS_GHC -O2 #-}
{-# OPTIONS_GHC -funfolding-use-threshold=16 #-}
{-# OPTIONS_GHC -fexcess-precision #-}
{-# OPTIONS_GHC -feager-blackholing #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# OPTIONS_GHC -fdicts-strict #-}
{-# OPTIONS_GHC -optc-O3 #-}
{-# OPTIONS_GHC -optc-ffast-math #-}

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

main :: IO ()
main = do
    n <- read <$> getLine :: IO Int
    xs <- (map (fst . fromJust . BC.readInt) . BC.words) <$> BC.getContents :: IO [Int]
    putStrLn . unwords . map show . go . zip [1..] $ xs
  where
    go ((x1,v1):(x2,v2):(x3,v3):vs)
      | v1 == v2 && v2 == v3 = go $ (x2,v2):(x3,v3):vs
      | v1 == v2 = [x2, x3]
      | v2 == v3 = [x1, x2]
      | v1 > v2 && v2 > v3 = [x1, x2]
      | v1 < v2 && v2 < v3 = [x1, x2]
      | v1 /= v3 = [x1, x3]
      | null vs = [-1]
      | v1 == v4 = [x2, x3]
      | v2 == v4 = [x1, x2]
      | v3 == v4 = [x2, x3]
      | otherwise = [x3, x4]
      where (x4, v4) = head vs
    go _ = [-1]

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

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

main = do
  n <- readLn :: IO Int
  if n<=2
     then print $ -1
     else B.getContents>>=putStrLn.unwords.map show.solve.zip[1..].map readInt.B.words

solve :: [(Int,Int)] -> [Int]
solve ((i,x):(j,y):(k,z):rest)
  | x==y && y==z = solve ((j,y):(k,z):rest)
  | x==y = [j,k]
  | y==z = [i,j]
  | z==x = solve ((i,x):(j,y):rest)
  | x<y  && y<z  = [i,j]
  | z>y  && y>x  = [i,j]
  | otherwise = [i,k]
solve _ = [-1]

import qualified Data.ByteString.Char8 as B

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

main = B.getContents>>=putStrLn.unwords.map show.solve.zip[1..].tail.map readInt.B.words

solve :: [(Int,Int)] -> [Int]
solve ((i,x):(j,y):(k,z):rest)
  | x==y && y==z = solve ((j,y):(k,z):rest)
  | x==y = [j,k]
  | y==z || x<y && y<z || x>y && y>z = [i,j]
  | z/=x = [i,k]
  | null rest = [-1]
  | y == w = [i,j]
  | otherwise = [k,l]
   where
     (l,w) = head rest
solve _ = [-1]


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

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

type Domain = (Int, [(Int, Int)])
type CoDomain = [Bool]
type Solver  = Domain -> CoDomain

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

getPair :: IO (Int, Int)
getPair = do
  [a, b] <- readChar8
  return (a, b)

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

parse :: IO Domain
parse = do
  [n, m] <- readChar8
  xs <- replicateM n getPair
  return (m, xs)

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

solve :: Solver
solve (m, xs) = result
  where
    mapAcc =  IntMap.unionsWith (+) $ (\(x,y) -> IntMap.fromList [(x-y, 1), (x, (-2)), (x+y, 1)]) <$> xs
    heights = tail $ toHeight <$> scanl f (0, 0, 0) (IntMap.toAscList mapAcc)
    highPoints = filter ((> m) . snd) heights
    leftMost = minimum $ (+m) <$> uncurry (-) <$> highPoints
    rightMost = maximum $ (+(-m)) <$> uncurry (+) <$> highPoints
    result = (\(x, y) -> null highPoints || x - y <= leftMost && x + y >= rightMost) <$> xs
    f (pos, ac, height) (nPos, acc) = (nPos, ac + acc, height + (nPos - pos) * ac)
    toHeight (xPos, _, height) = (xPos, height)

main :: IO ()
main = do
  [n] <- readChar8
  replicateM n $ printAns =<< solve <$> parse
  return ()

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

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

type Domain = (Int, [(Int, Int)])
type CoDomain = [Bool]
type Solver  = Domain -> CoDomain

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

getPair :: IO (Int, Int)
getPair = do
  [a, b] <- readChar8
  return (a, b)

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

parse :: IO Domain
parse = do
  [n, m] <- readChar8
  xs <- replicateM n getPair
  return (m, xs)

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

solve :: Solver
solve (m, xs) = result
  where
    mapAcc =  foldl' (\acc (x,y) -> IntMap.unionWith (+) (IntMap.fromList [(x-y, 1), (x, (-2)), (x+y, 1)]) acc) IntMap.empty xs
    heights = tail $ toHeight <$> scanl f (0, 0, 0) (IntMap.toAscList mapAcc)
    highPoints = filter ((> m) . snd) heights
    leftMost = minimum $ (+m) <$> uncurry (-) <$> highPoints
    rightMost = maximum $ (+(-m)) <$> uncurry (+) <$> highPoints
    result = (\(x, y) -> null highPoints || x - y <= leftMost && x + y >= rightMost) <$> xs
    f (pos, ac, height) (nPos, acc) = (nPos, ac + acc, height + (nPos - pos) * ac)
    toHeight (xPos, _, height) = (xPos, height)

main :: IO ()
main = do
  [n] <- readChar8
  replicateM n $ printAns =<< solve <$> parse
  return ()

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

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

type Domain = (Int, [(Int, Int)])
type CoDomain = [Bool]
type Solver  = Domain -> CoDomain

-- x in a
-- (x, y, a, b)
-- (start x, end x, start y, y per x unit )
type Segment = (Int, Int, Int, Int)

lookupSegGT :: Segment -> Set Segment -> Maybe Segment
lookupSegGT = goNothing
  where
    goNothing !_ Tip = Nothing
    goNothing x (Bin _ y l r) | (getEnd x) < (getEnd y) = goJust x y l
                              | otherwise = goNothing x r
    goJust !_ best Tip = Just best
    goJust x best (Bin _ y l r) | (getEnd x) < (getEnd y) = goJust x y l
                                | otherwise = goJust x best r

lookupIndexLt :: Segment -> Set Segment -> Int
lookupIndexLt x s = case Set.lookupLE x s of
  Just e -> fromJust $ Set.lookupIndex e s
  Nothing -> 0

lookupIndexGt :: Segment -> Set Segment -> Int
lookupIndexGt x s = case lookupSegGT x s of
  Just e -> 1 + fromJust (Set.lookupIndex e s)
  Nothing -> length s

splitSeg :: Segment -> Set Segment -> (Set Segment, Set Segment, Set Segment)
splitSeg x s = case Set.splitAt (lookupIndexLt x s) s of
  (l, xs) -> case Set.splitAt (lookupIndexGt x xs) xs of
    (overlap, r) -> (l, overlap, r)

notEmpty :: Segment -> Bool
notEmpty (x, y, a, b) = (x /= y) && (a /= 0 || b /= 0)

-- add two segments that intersected
addOrdered :: Segment -> (Segment, [Segment]) -> (Segment, [Segment])
addOrdered  a (b, acc) = case mergeSegment a b of
  (x, y) -> (x, y++acc)

negateSeg :: Segment -> Segment
negateSeg (x, y, a, b) = (x, y, -a, -b)

-- leave the right most part there
mergeSegment :: Segment -> Segment -> (Segment, [Segment])
mergeSegment a@(x1, y1, a1, b1) b@(x2, y2, a2, b2)
  -- a b
  | y1 <= x2 = (a, [b])
  -- b a
  | y2 <= x1 = mergeSegment b a
  -- a contains b
  -- as : bs, bs be; be ae
  | x1 <= x2 && y1 >= y2 = ((x1,x2,a1,b1), [(x2,y2,(x2-x1)*b1+a1+a2,b1+b2),(y2,y1,(y2-x1)*b1+a1,b1)])
  -- b contains a
  | x2 <= x1 && y2 >= y1 = mergeSegment b a
  -- insert a b
  | x1 <= x2 = ((x1,x2,a1,b1), ([(x2, y1, (x2-x1)*b1+a1+a2, b1+b2), (y1,y2,(y1-x2)*b2+a2, b2)]))
  | otherwise = mergeSegment b a

-- maintain none overlapping segments
toSegments :: Int -> Int  -> [Segment]
toSegments x p = [(x-p, x, 0, 1), (x, x + p, p, -1)]

-- find the left end pos, find the right end pos
-- merge all inner segments
addSegment :: Segment -> Set Segment -> Set Segment
addSegment x s = case (splitSeg x s) of
  (l, overlap, r) -> Set.fromAscList $ Set.toAscList l ++ insertSegment x (Set.toAscList overlap) ++ Set.toAscList r
    where
      insertSegment :: Segment -> [Segment] -> [Segment]
      insertSegment s xs =  filter notEmpty $ uncurry (:) $ foldr addOrdered (s, []) xs

-- xs - ys
removeSegments :: Set Segment -> [Segment] -> Set Segment
removeSegments xs ys = foldr subSegment xs ys
  where
    subSegment :: Segment -> Set Segment -> Set Segment
    subSegment s xs = addSegment (negateSeg s) xs

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

getPair :: IO (Int, Int)
getPair = do
  [a, b] <- readChar8
  return (a, b)

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

parse :: IO Domain
parse = do
  [n, m] <- readChar8
  xs <- replicateM n getPair
  return (m, xs)

-- solveOne :: Int -> Int -> Int -> [Int] -> Bool
-- solveOne total n m xs = (not (null ks) && (maximum ks) > 2 || even m) && sum ks >= m
--   where ks = filter (>1) $ map (`div` n) xs

getStart :: Segment -> Int
getStart (x, _, _, _) = x

getEnd :: Segment -> Int
getEnd (_, y, _, _) = y

getStartHeight :: Segment -> Int
getStartHeight (_, _, a, _) = a

getEndHeight :: Segment -> Int
getEndHeight (x1, x2, a, b) = a + (x2-x1) * b

getHeight :: Segment -> Int
getHeight s = max (getStartHeight s) (getEndHeight s)

containsPoint :: Int -> (Int, Int) -> Bool
containsPoint x (a,b) = a - b <= x && x <= a + b

getHighest :: Set Segment -> Maybe Segment
getHighest xs = if Set.null xs
  then Nothing
  else Just $ maximumBy (comparing getHeight) $ Set.toAscList  xs

getHeightPos :: Segment -> Int
getHeightPos (x1, x2, _, b)
  | b >= 0 = x2
  | otherwise = x1

-- (Height, height of the position)
computeHighPoint :: Set Segment -> (Int, Int)
computeHighPoint xs = case getHighest xs of
  Just seg -> (getHeight seg,  getHeightPos seg)
  Nothing -> (0, 0)

computeHigh :: Set Segment -> Int
computeHigh = fst . computeHighPoint

-- remove seg, height lower than m after removal
solveOne :: (Int,Int) -> Int -> Set Segment -> (Int, Int) -> Bool
solveOne (height, hightPos) m merged xs = (height <= m) || (containsPoint hightPos xs && (computeHigh $ removeSegments merged $ uncurry toSegments xs) <= m)

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

solve :: Solver
solve (m, xs) = result
  where
    mapAcc =  foldl' (\acc (x,y) -> IntMap.unionWith (+) (IntMap.fromList [(x-y, 1), (x, (-2)), (x+y, 1)]) acc) IntMap.empty xs
    heights = tail $ toHeight <$> scanl f (0, 0, 0) (IntMap.toAscList mapAcc)
    highPoints = filter ((> m) . snd) heights
    leftMost = minimum $ (+m) <$> uncurry (-) <$> highPoints
    rightMost = maximum $ (+(-m)) <$> uncurry (+) <$> highPoints
    result = (\(x, y) -> null highPoints || x - y <= leftMost && x + y >= rightMost) <$> xs
    f (pos, ac, height) (nPos, acc) = (nPos, ac + acc, height + (nPos - pos) * ac)
    toHeight (xPos, _, height) = (xPos, height)

solve1 :: Solver
solve1 (m, xs) =
  -- traceShow (m, xs, segments, computeHighPoint merged, ys)
  results
  where
        segments = concatMap (uncurry toSegments) xs
        merged = foldr addSegment Set.empty segments
        (height, hightPos) = computeHighPoint merged
        -- ys = (computeHigh . removeSegments merged . uncurry toSegments) <$> xs
        ys = traceShowId <$> (id &&& computeHigh) <$> (removeSegments merged . uncurry toSegments) <$> xs
        -- containsPointSegments = uncurry toSegments <$> filter (containsPoint hightPos) xs
        results = solveOne (height, hightPos) m merged <$> xs

main :: IO ()
main = do
  [n] <- readChar8
  replicateM n $ printAns =<< solve <$> parse
  return ()

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

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

type Domain = (Int, [(Int, Int)])
type CoDomain = [Bool]
type Solver  = Domain -> CoDomain

-- x in a
-- (x, y, a, b)
-- (start x, end x, start y, y per x unit )
type Segment = (Int, Int, Int, Int)

lookupSegGT :: Segment -> Set Segment -> Maybe Segment
lookupSegGT = goNothing
  where
    goNothing !_ Tip = Nothing
    goNothing x (Bin _ y l r) | (getEnd x) < (getEnd y) = goJust x y l
                              | otherwise = goNothing x r
    goJust !_ best Tip = Just best
    goJust x best (Bin _ y l r) | (getEnd x) < (getEnd y) = goJust x y l
                                | otherwise = goJust x best r

lookupIndexLt :: Segment -> Set Segment -> Int
lookupIndexLt x s = case Set.lookupLE x s of
  Just e -> fromJust $ Set.lookupIndex e s
  Nothing -> 0

lookupIndexGt :: Segment -> Set Segment -> Int
lookupIndexGt x s = case lookupSegGT x s of
  Just e -> 1 + fromJust (Set.lookupIndex e s)
  Nothing -> length s

splitSeg :: Segment -> Set Segment -> (Set Segment, Set Segment, Set Segment)
splitSeg x s = case Set.splitAt (lookupIndexLt x s) s of
  (l, xs) -> case Set.splitAt (lookupIndexGt x xs) xs of
    (overlap, r) -> (l, overlap, r)

notEmpty :: Segment -> Bool
notEmpty (x, y, a, b) = (x /= y) && (a /= 0 || b /= 0)

-- add two segments that intersected
addOrdered :: Segment -> (Segment, [Segment]) -> (Segment, [Segment])
addOrdered  a (b, acc) = case mergeSegment a b of
  (x, y) -> (x, y++acc)

negateSeg :: Segment -> Segment
negateSeg (x, y, a, b) = (x, y, -a, -b)

-- leave the right most part there
mergeSegment :: Segment -> Segment -> (Segment, [Segment])
mergeSegment a@(x1, y1, a1, b1) b@(x2, y2, a2, b2)
  -- a b
  | y1 <= x2 = (a, [b])
  -- b a
  | y2 <= x1 = mergeSegment b a
  -- a contains b
  -- as : bs, bs be; be ae
  | x1 <= x2 && y1 >= y2 = ((x1,x2,a1,b1), [(x2,y2,(x2-x1)*b1+a1+a2,b1+b2),(y2,y1,(y2-x1)*b1+a1,b1)])
  -- b contains a
  | x2 <= x1 && y2 >= y1 = mergeSegment b a
  -- insert a b
  | x1 <= x2 = ((x1,x2,a1,b1), ([(x2, y1, (x2-x1)*b1+a1+a2, b1+b2), (y1,y2,(y1-x2)*b2+a2, b2)]))
  | otherwise = mergeSegment b a

-- maintain none overlapping segments
toSegments :: Int -> Int  -> [Segment]
toSegments x p = [(x-p, x, 0, 1), (x, x + p, p, -1)]

-- find the left end pos, find the right end pos
-- merge all inner segments
addSegment :: Segment -> Set Segment -> Set Segment
addSegment x s = case (splitSeg x  s) of
  (l, overlap, r) -> Set.fromAscList $ Set.toAscList l ++ insertSegment x (Set.toAscList overlap) ++ Set.toAscList r
    where
      insertSegment :: Segment -> [Segment] -> [Segment]
      insertSegment s xs =  filter notEmpty $ uncurry (:) $ foldr addOrdered (s, []) xs

-- xs - ys
removeSegments :: Set Segment -> [Segment] -> Set Segment
removeSegments xs ys = foldr subSegment xs ys
  where
    subSegment :: Segment -> Set Segment -> Set Segment
    subSegment s xs = addSegment (negateSeg s) xs

readChar8 :: IO [Int]
readChar8 = fmap read . words <$> getLine

getPair :: IO (Int, Int)
getPair = do
  [a, b] <- readChar8
  return (a, b)

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

parse :: IO Domain
parse = do
  [n, m] <- readChar8
  xs <- replicateM n getPair
  return (m, xs)

-- solveOne :: Int -> Int -> Int -> [Int] -> Bool
-- solveOne total n m xs = (not (null ks) && (maximum ks) > 2 || even m) && sum ks >= m
--   where ks = filter (>1) $ map (`div` n) xs

getStart :: Segment -> Int
getStart (x, _, _, _) = x

getEnd :: Segment -> Int
getEnd (_, y, _, _) = y

getStartHeight :: Segment -> Int
getStartHeight (_, _, a, _) = a

getEndHeight :: Segment -> Int
getEndHeight (x1, x2, a, b) = a + (x2-x1) * b

getHeight :: Segment -> Int
getHeight s = max (getStartHeight s) (getEndHeight s)

containsPoint :: Int -> (Int, Int) -> Bool
containsPoint x (a,b) = a - b <= x && x <= a + b

getHighest :: Set Segment -> Segment
getHighest xs = maximumBy (comparing getHeight) $ Set.toAscList  xs

getHeightPos :: Segment -> Int
getHeightPos (x1, x2, _, b)
  | b >= 0 = x2
  | otherwise = x1

-- (Height, height of the position)
computeHighPoint :: Set Segment -> (Int, Int)
computeHighPoint xs = (getHeight seg,  getHeightPos seg) where seg = getHighest xs

computeHigh :: Set Segment -> Int
computeHigh = fst . computeHighPoint

-- remove seg, height lower than m after removal
solveOne :: Int -> Int -> Set Segment -> (Int, Int) -> Bool
solveOne hightPoint m merged xs = containsPoint hightPoint xs && (computeHigh $ removeSegments merged $ uncurry toSegments xs) <= m

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

solve :: Solver
solve (m, xs) =
  -- traceShow (xs, segments, computeHighPoint merged, ys)
  results
  where
        segments = concatMap (uncurry toSegments) xs
        merged = foldr addSegment Set.empty segments
        hightPos = snd $ computeHighPoint merged
        -- ys = (computeHigh . removeSegments merged . uncurry toSegments) <$> xs
        -- ys = traceShowId <$> (id &&& computeHigh) <$> (removeSegments merged . uncurry toSegments) <$> xs
        -- containsPointSegments = uncurry toSegments <$> filter (containsPoint hightPos) xs
        results = solveOne hightPos m merged <$> xs

main :: IO ()
main = do
  [n] <- readChar8
  replicateM n $ printAns =<< solve <$> parse
  return ()

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

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

type Domain = (Int, [(Int, Int)])
type CoDomain = [Bool]
type Solver  = Domain -> CoDomain

-- x in a
-- (x, y, a, b)
-- (start x, end x, start y, y per x unit )
type Segment = (Int, Int, Int, Int)

lookupSegGT :: Segment -> Set Segment -> Maybe Segment
lookupSegGT = goNothing
  where
    goNothing !_ Tip = Nothing
    goNothing x (Bin _ y l r) | (getEnd x) < (getEnd y) = goJust x y l
                              | otherwise = goNothing x r
    goJust !_ best Tip = Just best
    goJust x best (Bin _ y l r) | (getEnd x) < (getEnd y) = goJust x y l
                                | otherwise = goJust x best r

lookupIndexLt :: Segment -> Set Segment -> Int
lookupIndexLt x s = case Set.lookupLE x s of
  Just e -> fromJust $ Set.lookupIndex e s
  Nothing -> 0

lookupIndexGt :: Segment -> Set Segment -> Int
lookupIndexGt x s = case lookupSegGT x s of
  Just e -> 1 + fromJust (Set.lookupIndex e s)
  Nothing -> length s

splitSeg :: Segment -> Set Segment -> (Set Segment, Set Segment, Set Segment)
splitSeg x s = case Set.splitAt (lookupIndexLt x s) s of
  (l, xs) -> case Set.splitAt (lookupIndexGt x xs) xs of
    (overlap, r) -> (l, overlap, r)

notEmpty :: Segment -> Bool
notEmpty (x, y, _, _) = not $ x == y

-- add two segments that intersected
addOrdered :: Segment -> (Segment, [Segment]) -> (Segment, [Segment])
addOrdered  a (b, acc) = case mergeSegment a b of
  (x, y) -> (x, y++acc)

negateSeg :: Segment -> Segment
negateSeg (x, y, a, b) = (x, y, -a, -b)

-- leave the right most part there
mergeSegment :: Segment -> Segment -> (Segment, [Segment])
mergeSegment a@(x1, y1, a1, b1) b@(x2, y2, a2, b2)
  -- a b
  | y1 <= x2 = (a, [b])
  -- b a
  | y2 <= x1 = mergeSegment b a
  -- a contains b
  -- as : bs, bs be; be ae
  | x1 <= x2 && y1 >= y2 = ((x1,x2,a1,b1), [(x2,y2,(x2-x1)*b1+a1+a2,b1+b2),(y2,y1,(y2-x1)*b1+a1,b1)])
  -- b contains a
  | x2 <= x1 && y2 >= y1 = mergeSegment b a
  -- insert a b
  | x1 <= x2 = ((x1,x2,a1,b1), ([(x2, y1, (x2-x1)*b1+a1+a2, b1+b2), (y1,y2,(y1-x2)*b2+a2, b2)]))
  | otherwise = mergeSegment b a

-- maintain none overlapping segments
toSegments :: Int -> Int  -> [Segment]
toSegments x p = [(x-p, x, 0, 1), (x, x + p, p, -1)]

-- find the left end pos, find the right end pos
-- merge all inner segments
addSegment :: Segment -> Set Segment -> Set Segment
addSegment x s = case (splitSeg x  s) of
  (l, overlap, r) -> Set.fromAscList $ Set.toAscList l ++ insertSegment x (Set.toAscList overlap) ++ Set.toAscList r
    where
      insertSegment :: Segment -> [Segment] -> [Segment]
      insertSegment s xs =  filter notEmpty $ uncurry (:) $ foldr addOrdered (s, []) xs

-- xs - ys
removeSegments :: Set Segment -> [Segment] -> Set Segment
removeSegments xs ys = foldr subSegment xs ys
  where
    subSegment :: Segment -> Set Segment -> Set Segment
    subSegment s xs = addSegment (negateSeg s) xs

readChar8 :: IO [Int]
readChar8 = fmap read . words <$> getLine

getPair :: IO (Int, Int)
getPair = do
  [a, b] <- readChar8
  return (a, b)

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

parse :: IO Domain
parse = do
  [n, m] <- readChar8
  xs <- replicateM n getPair
  return (m, xs)

-- solveOne :: Int -> Int -> Int -> [Int] -> Bool
-- solveOne total n m xs = (not (null ks) && (maximum ks) > 2 || even m) && sum ks >= m
--   where ks = filter (>1) $ map (`div` n) xs

getStart :: Segment -> Int
getStart (x, _, _, _) = x

getEnd :: Segment -> Int
getEnd (_, y, _, _) = y

getStartHeight :: Segment -> Int
getStartHeight (_, _, a, _) = a

getEndHeight :: Segment -> Int
getEndHeight (x1, x2, a, b) = a + (x2-x1) * b

getHeight :: Segment -> Int
getHeight s = max (getStartHeight s) (getEndHeight s)

containsPoint :: Int -> (Int, Int) -> Bool
containsPoint x (a,b) = a - b <= x && x <= a + b

getHighest :: Set Segment -> Segment
getHighest xs = maximumBy (comparing getHeight) $ Set.toAscList  xs

getHeightPos :: Segment -> Int
getHeightPos (x1, x2, _, b)
  | b >= 0 = x2
  | otherwise = x1

-- (Height, height of the position)
computeHighPoint :: Set Segment -> (Int, Int)
computeHighPoint xs = (getHeight seg,  getHeightPos seg) where seg = getHighest xs

computeHigh :: Set Segment -> Int
computeHigh = fst . computeHighPoint

-- remove seg, height lower than m
solveOne :: Int -> Int -> Set Segment -> (Int, Int) -> Bool
solveOne hightPoint m merged xs = containsPoint hightPoint xs && (computeHigh $ removeSegments merged $ uncurry toSegments xs) > m

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

solve :: Solver
solve (m, xs) = results -- ++ show xs ++ ":" -- ++ show containsPointSegments
  where
        merged = foldr addSegment Set.empty (concatMap (uncurry toSegments) xs)
        hightPoint = snd $ computeHighPoint merged
        containsPointSegments = uncurry toSegments <$> filter (containsPoint hightPoint) xs
        results = solveOne hightPoint m merged <$> xs

main :: IO ()
main = do
  [n] <- readChar8
  replicateM n $ printAns =<< solve <$> parse
  return ()


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

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

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

main :: IO ()
main = do
  [t] <- getInts
  output <- fmap mconcat $ replicateM t $ do
    [n] <- getInts
    _ <- C.getLine
    let f j i = intDec j `mappend` charUtf8 ' ' `mappend` intDec (2 * i - 1) `mappend` charUtf8 ' ' `mappend` intDec (2 * i) `mappend` charUtf8 '\n'
        func i = f 1 i `mappend` f 2 i `mappend` f 1 i `mappend` f 2 i `mappend` f 1 i `mappend` f 2 i
        result = mconcat [func i | i <- [1 .. n `div` 2]]
    return $ intDec (3 * n) `mappend` charUtf8 '\n' `mappend` result
  hPutBuilder stdout output

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

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

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [t] <- readInts
  replicateM_ t $ do
    [n] <- readInts
    _a <- readInts
    let
      n2 = div n 2
    putInts [n2 * 6]
    forM_ [1 .. n2] $ \iv -> replicateM_ 2 $ do
      putInts [1, iv*2 - 1, iv*2]
      putInts [2, iv*2 - 1, iv*2]
      putInts [1, iv*2 - 1, iv*2]

type SIO = StateT P.ByteString IO

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

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

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


{-# OPTIONS_GHC -O2 #-}

import Control.Monad
import Prelude as P

import Data.Word (Word8)
import Data.Int (Int64)
import qualified Data.Bits as Bits
import qualified Data.Char as Char

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

import qualified Data.ByteString as Bs
import qualified System.IO as Io
--import Data.IntSet

fill :: Map.Map (Int, Int) Int -> Int -> Int -> Int -> Int -> Int -> Map.Map (Int, Int) Int
fill m xmax cnt a x y
  | cnt == 1 && not memb = newmap
  | left = if memb then fill m xmax cnt a x (y-1) else fill newmap xmax (cnt-1) a x (y-1)
  | down = if memb then fill m xmax cnt a (x+1) y else fill newmap xmax (cnt-1) a (x+1) y
  | right = if memb then fill m xmax cnt a x (y+1) else fill newmap xmax (cnt-1) a x (y+1)
  | otherwise = error "nowhere to go"
  where memb = Map.member (x, y) m
        left = y > 1 && Map.notMember (x, y-1) m
        right = y < x && Map.notMember (x, y+1) m
        down = x < xmax && Map.notMember (x+1, y) m
        newmap = Map.insert (x, y) a m

solve :: IO ()
solve = do
  n <- readLn :: IO Int
  xs <- readInts :: IO [Int]
  let res = foldl (\m (x, i) -> fill m n x x i i) Map.empty $ zip xs [1..n]
      lines = [zip (repeat i) [1..i] |  i <- [1..n]]
      sol = intercalate "\n" $ map (intercalate " " . map (\k -> show . Map.findWithDefault 0 k $ res)) lines
    in putStrLn sol

main = do
  let t = 1
  replicateM_ t $ solve

----------------------------------------------------------------------------------------
readrows :: (Integral a, Integral b) => b -> IO [[a]]
readrows 0 = return []
readrows n = do
  row <- readInts
  l <- readrows $ n-1
  return (row : l)

parseInt :: (Integral a) => Bs.ByteString -> a
parseInt xs = snd $ Bs.foldr (\y (pow, acc) -> (pow*10, acc + pow*(fromIntegral (y-48)))) (1, 0) xs

readInts :: (Integral a) => IO [a]
readInts =  map parseInt . filter (/=Bs.empty) . Bs.splitWith (==32) . fuckingWindowsCRLF <$> Bs.getLine
  where fuckingWindowsCRLF bs = if Bs.last bs == 13 then Bs.init bs else bs

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

putInts :: [Int] -> Builder
putInts xs = (mconcat $ intersperse (charUtf8 ' ') $ map intDec xs) `mappend` (charUtf8 '\n')

main :: IO ()
main = do
  [n] <- getInts
  ps <- getInts
  let ps' = scanl' acc ps [1..n-1]
        where acc xs t = filter (/= t) xs
      transform cnt pss
        | cnt > n = []
        | otherwise = reverse (map head as) : transform (cnt + 1) (map tail as ++ bs)
        where (as, bs) = splitAt cnt pss
      output = mconcat $ map putInts $ transform 1 ps'
  hPutBuilder stdout output

import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S

import qualified Data.Array as A

import Data.Bits(xor)

import Data.Array((!))
import Control.Monad(replicateM)

import Data.Maybe

solve :: Integer -> [Integer] -> [[Integer]]
solve 1 [1] = [[1]]
solve 1 _ = error "impossile"

solve 2 [1, 2] = [[1], [2, 2]]
solve 2 [2, 1] = [[2], [2, 1]]
solve 2 _ = error "impossible"

solve n diag = [diag !! 0] : fmap (\(i, j) -> (fmap (+1) j)++[i]) (zip (tail diag) solution) where
	solution = solve (n-1) $ fmap (\i->i-1) $ filter (/=1) diag

showR :: [[Integer]] -> String
showR (x:xs) = foldr (\i s->show i ++ " " ++ s) "\n" x ++ showR xs
showR [] = []

main = do
	let t = 1 -- t <- getLine >>= return . read :: IO Int
	replicateM t $ do
		[n] <- getLine >>= return . (fmap read) . words :: IO [Integer]
		diag <- getLine >>= return . (fmap read) . words :: IO [Integer]
		putStr $ showR $ solve n diag


import qualified Data.Set as S

getChunksSizes :: String -> S.Set Char -> [Int]
getChunksSizes xs set = go xs 0 where
    go [] acc = [acc]
    go (x : xs) acc =
        if S.member x set then acc : go xs 0
        else go xs (acc + 1)

summation :: Int -> Integer
summation n = x*(x + 1) `div` 2 where
    x = toInteger n

getNumSubs :: String -> S.Set Char -> Integer
getNumSubs xs keys = foldl (+) 0 $ map summation (getChunksSizes xs keys)

getMissingKeys :: String -> String ->  S.Set Char
getMissingKeys xs keys = S.difference setXs setKeys where
    setXs = S.fromList xs
    setKeys = S.fromList keys

main =
    getLine >> getLine >>= \xs ->
    concat . words <$> getLine >>= \keys ->
    print $ getNumSubs xs (getMissingKeys xs keys)

import Control.Monad

solve :: String -> [Char] -> [Integer]
solve inp  l =uncurry (:) (foldl f (0,[]) inp )
  where
    f (count,list) char
      |char `elem` l = (count+1,list)
      |otherwise = (0,count:list)

c :: [Integer] -> Integer
c =sum. map (\x -> x*(x+1) `div` 2)

routine :: IO ()
routine = do
  _ <- getLine
  m <- getLine
  l <- (concat.words) <$>getLine
  print $ c $  solve m l

main :: IO ()
main = do
  routine

main :: IO ()
main = getLine >> f <$> input >>= print
  where f (s, d) = solve d s

type Dict = String

input :: IO (String, Dict)
input = (,) <$> getLine <*> fmap (mconcat . words) getLine

nextToken :: Dict -> String -> (String, String)
nextToken dict = span pred . dropUntil pred
  where pred = (`elem` dict)
        dropUntil p = dropWhile $ not . p

solve :: Dict -> String -> Integer
solve _ [] = 0
solve dict s = f (fromIntegral $ length t) + solve dict r
  where (t, r) = nextToken dict s
        f l = (l + 1) * l `div` 2

import Control.Monad

solve :: String -> [Char] -> [Int]
solve inp  l =uncurry (:) (foldl f (0,[]) inp )
  where
    f (count,list) char
      |char `elem` l = (count+1,list)
      |otherwise = (0,count:list)

c :: [Int] -> Int
c =sum. map (\x -> x*(x+1) `div` 2)

routine :: IO ()
routine = do
  _ <- getLine
  m <- getLine
  l <- (concat.words) <$>getLine
  print $ c $  solve m l

main :: IO ()
main = do
  routine

main :: IO ()
main = getLine >> f <$> input >>= print
  where f (s, d) = solve d s

type Dict = String

input :: IO (String, Dict)
input = (,) <$> getLine <*> fmap (mconcat . words) getLine

nextToken :: Dict -> String -> (String, String)
nextToken dict = span pred . dropUntil pred
  where pred = (`elem` dict)
        dropUntil p = dropWhile $ not . p

solve :: Dict -> String -> Int
solve _ [] = 0
solve dict s = f (length t) + solve dict r
  where (t, r) = nextToken dict s
        f l = (l + 1) * l `div` 2

import qualified Data.Set as S

getChunksSizes :: String -> S.Set Char -> [Int]
getChunksSizes xs set = go xs 0 where
    go [] acc = [acc]
    go (x : xs) acc =
        if S.member x set then acc : go xs 0
        else go xs (acc + 1)

summation :: Int -> Int
summation n = n*(n + 1) `div` 2

getNumSubs :: String -> S.Set Char -> Int
getNumSubs xs keys = foldl (+) 0 $ map summation (getChunksSizes xs keys)

getMissingKeys :: String -> String ->  S.Set Char
getMissingKeys xs keys = S.difference setXs setKeys where
    setXs = S.fromList xs
    setKeys = S.fromList keys

main =
    getLine >> getLine >>= \xs ->
    concat . words <$> getLine >>= \keys ->
    print $ getNumSubs xs (getMissingKeys xs keys)


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

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

bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs=case B.readInt bs of{Just(n,_)->n;_->error$"readInt error : bs = "++show bs;}
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep n f=foldr((>>).f)(return())[0..n-1]
rev n f=foldr((>>).f.negate)(return())[1-n..0]
for :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
for a b f=foldr((>>).f)(return())[a..b]
{-# INLINE rep #-}
{-# INLINE rev #-}
{-# INLINE for #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

main :: IO ()
main = do
  hName <- getLine
  aName <- getLine
  _n <- getLine
  ttpcs <- sort.parse.words <$> getContents
  case solve hName aName ttpcs of
    [] -> return ()
    res -> putStr $ unlines res

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs=case B.readInt bs of{Just(n,_)->n;_->error$"readInt error : bs = "++show bs;}
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep n f=foldr((>>).f)(return())[0..n-1]
rev n f=foldr((>>).f.negate)(return())[1-n..0]
for :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
for a b f=foldr((>>).f)(return())[a..b]
{-# INLINE rep #-}
{-# INLINE rev #-}
{-# INLINE for #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

main :: IO ()
main = do
  hName <- getLine
  aName <- getLine
  _n <- getLine
  ttpcs <- parse.words <$> getContents
  case solve hName aName ttpcs of
    [] -> return ()
    res -> putStr $ unlines res

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

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

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

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

bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs=case B.readInt bs of{Just(n,_)->n;_->error$"readInt error : bs = "++show bs;}
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep n f=foldr((>>).f)(return())[0..n-1]
rev n f=foldr((>>).f.negate)(return())[1-n..0]
for :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
for a b f=foldr((>>).f)(return())[a..b]
{-# INLINE rep #-}
{-# INLINE rev #-}
{-# INLINE for #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

main :: IO ()
main = do
  hName <- getLine
  aName <- getLine
  _n <- getLine
  ttpcs <- sort.parse.words <$> getContents
  case solve hName aName ttpcs of
    [] -> return ()
    res -> putStr $ unlines res

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

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

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

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

bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs=case B.readInt bs of{Just(n,_)->n;_->error$"readInt error : bs = "++show bs;}
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep n f=foldr((>>).f)(return())[0..n-1]
rev n f=foldr((>>).f.negate)(return())[1-n..0]
for :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
for a b f=foldr((>>).f)(return())[a..b]
{-# INLINE rep #-}
{-# INLINE rev #-}
{-# INLINE for #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

main :: IO ()
main = do
  hName <- getLine
  aName <- getLine
  _n <- getLine
  getContents>>=putStr.init.unlines.solve hName aName.sort.parse.words

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

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

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

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

bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs=case B.readInt bs of{Just(n,_)->n;_->error$"readInt error : bs = "++show bs;}
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep n f=foldr((>>).f)(return())[0..n-1]
rev n f=foldr((>>).f.negate)(return())[1-n..0]
for :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
for a b f=foldr((>>).f)(return())[a..b]
{-# INLINE rep #-}
{-# INLINE rev #-}
{-# INLINE for #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

main :: IO ()
main = do
  hName <- getLine
  aName <- getLine
  _n <- getLine
  getContents>>=putStr.unlines.solve  hName aName.sort.parse.words

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

forFoldM_ v s f = foldM_ f v s

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

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

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

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

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

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

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

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

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

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

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

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

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

forFoldM_ v s f = foldM_ f v s

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

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

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

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

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

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

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

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


{-# OPTIONS_GHC -O2 #-}

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

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

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

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

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

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

data Queue = Q [Vertex] [Vertex]

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

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

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

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

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

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

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

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

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

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

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

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

inf :: Cost
inf = 1000000000

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

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

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

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

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

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

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

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

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