Haskell: コード祭り予選突破練習会コンテスト

普段と違う頭を使う感じで楽しい。

https://not-522.appspot.com/contest/6671465998974976

ダブル文字列/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
  d <- readArray dist u
  es <- readArray g u
  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