# pekempeyのブログ

#### ダブル文字列/Double String

main = getLine >>= putStrLn . concat . replicate 2


#### B - とても長い数列

main = getLine >> getLine >>= print . sum . zipWith (*) (map (2^) [0..]) . reverse . map read . words


#### 8月31日

import Data.List
import Control.Applicative

main = do
[_, t] <- map read . words <$> getLine ab <- map (map read . words) . lines <$> getContents
print $solve ab t solve :: [[Int]] -> Int -> Int solve a t = case findIndex (>= (sa - t)) cumsum of Just x -> x; Nothing -> -1 where sa = sum . map (\[x, _] -> x)$ a
cumsum = scanl (+) 0 $reverse . sort . map (\[x, y] -> x - y)$ a


#### C - 錬金術師

あまり綺麗ではないかな。

main = getContents >>= putStrLn . yesno . solve . lines

yesno :: Bool -> String
yesno x = if x then "YES" else "NO"

myadd :: (Int, Int) -> (Int, Int) -> (Int, Int)
myadd (a, b) (c, d) = (a + c, b + d)

between :: Int -> (Int, Int) -> Bool
between c (a, b) = a <= c && c <= b

solve :: [String] -> Bool
solve [a, b, c] = between (length c div 2) . foldl1 myadd . map (minmax a b c) $['A'..'Z'] minmax :: String -> String -> String -> Char -> (Int, Int) minmax a b c t = (mn, mx) where n = length a sameA = length . filter (==t)$ a
sameB = length . filter (==t) $b sameC = length . filter (==t)$ c
mn = if sameA + sameB < sameC then 1000000 else max 0 $sameC - sameB mx = min sameC sameA  #### D - 登山家 スタックを fold した。ちょっとごちゃごちゃしてる。 import Debug.Trace main = getLine >> getContents >>= putStr . unlines . map show . solve . map read . lines solve :: [Int] -> [Int] solve a = map (pred . pred)$ zipWith (+) l r
where
n = length a
f :: [(Int, Int)] -> (Int, Int) -> [(Int, Int)]
f s (t, i) = (t, i) : dropWhile ((t >=) . fst) s
l = zipWith dist [0..] . map (snd . head . drop 1) . drop 1 . scanl f [(1000000000, -1)] $zip a [0..] r = zipWith dist [0..] . map (snd . head . drop 1) . take n . scanr (flip f) [(1000000000, n)]$ zip a [0..]

dist :: Int -> Int -> Int
dist a b = abs $a - b  ### C - 直径 queue は自前実装。標準だと seq があるけど、前試したときは自前で書いた方が早かったのでそうした。bfs の良い実装あるんだろうか。 import Control.Applicative import Control.Monad import Debug.Trace import Data.Array.IO import Data.IORef -- two stack queue -- ref: Chris Okasaki "Purely Functional Data Structures" p.42 data Queue a = Node [a] [a] deriving (Show) queueEmpty = Node [] [] queueNull (Node [] []) = True queueNull (Node _ _) = False enqueue x (Node s1 s2) = Node s1 (x : s2) dequeue (Node [] s2) = dequeue (Node (reverse s2) []) dequeue (Node (s:s1) s2) = (s, Node s1 s2) main :: IO () main = do [n1, m1] <- map read . words <$> getLine
e1 <- map (map read . words) <$> replicateM m1 getLine :: IO [[Int]] [n2, m2] <- map read . words <$> getLine
e2 <- map (map read . words) <$> replicateM m2 getLine :: IO [[Int]] (mn1, mx1) <- solve n1 e1 (mn2, mx2) <- solve n2 e2 let mn = maximum [mn1 + mn2 + 1, mx1, mx2] let mx = mx1 + mx2 + 1 putStrLn$ show mn ++ " " ++ show mx

solve :: Int -> [[Int]] -> IO (Int, Int)
solve n es = do
g <- newArray (0, n - 1) [] :: IO (IOArray Int [Int])
forM_ es $\[u, v] -> do readArray g u >>= writeArray g u . (v:) readArray g v >>= writeArray g v . (u:) vals <- mapM (minmax n g) [0..n-1] let mn = minimum vals let mx = maximum vals return (mn, mx) minmax :: Int -> IOArray Int [Int] -> Int -> IO Int minmax n g u = do dist <- newArray (0, n - 1) (-1) :: IO (IOArray Int Int) writeArray dist u 0 let q = enqueue u queueEmpty d <- bfs dist g q dd <- getElems d return$ maximum dd

bfs :: IOArray Int Int -> IOArray Int [Int] -> Queue Int -> IO (IOArray Int Int)
bfs dist g (Node [] []) = return dist
bfs dist g q1 = do
let (u, q2) = dequeue q1
q <- newIORef q2
forM_ es $\v -> do dv <- readArray dist v when (dv == (-1))$ do
writeArray dist v (d + 1)
modifyIORef q (enqueue v)

bfs dist g =<< readIORef q


#### D - お釣りの嫌いな高橋くん

normalize しておけば carry の上限が 2 に抑えられるので、DP も foldr で楽々できる。Haskell で書くと気持ちがいい問題だった。

import Debug.Trace

main = getLine >> getContents >>= print . solve . normalize 0 . map read . lines

normalize :: Int -> [Int] -> [Int]
normalize v []
| v == 0    = [0]
| otherwise = normalize 0 [v]
normalize v (x:xs) = let xx = x + v; q = max 0 (xx div 10 - 1)
in (xx - q * 10) : normalize q xs

solve :: [Int] -> Int
solve a = case foldr f (F 1, F 0, F 0) a of (F x, _, _) -> if x == 0 then modulus - 1 else x - 1
where
g :: Int -> (F, F, F) -> F
g v (a, b, c)
| v < 10    = a * F (v + 1)
| v < 20    = b * F (v mod 10 + 1) + a * F (9 - v mod 10)
| otherwise = c * F (v mod 10 + 1) + b * F (9 - v mod 10)

f :: Int -> (F, F, F) -> (F, F, F)
f v a = (g v a, g (v + 1) a, g (v + 2) a)

modulus :: Int
modulus = 10^9 + 7

data F = F Int deriving (Show)

instance Num F where
F a + F b = F $(a + b) mod modulus F a * F b = F$ (a * b) mod modulus
abs = id
signum _ = F 1
fromInteger x = F (fromIntegral x)
negate (F a) = F \$ if a == 0 then 0 else modulus - a


#### References

Chapters - Learn You a Haskell for Great Good!