Haskell: ABC075

A 問題

-- Exec time: 2 ms
-- Memory usage: 508 KB
{-# LANGUAGE ScopedTypeVariables #-}
import Data.Bits
main = getLine >>= print . foldl1 xor . map (read :: String -> Int) . words

B 問題

あまり面白くない書き方。

-- Exec time: 6 ms
-- Memory usage: 1148 KB
import Control.Applicative
import Control.Monad
import Data.Char
 
main = do
  [h, w] <- map read . words <$> getLine
  g <- replicateM h getLine
  mapM putStrLn . solve $ g
 
solve :: [String] -> [String]
solve g = [[f i j | j <- [0..w-1]] | i <- [0..h-1]]
  where
    h = length g
    w = length . head $ g
 
    inside :: Int -> Int -> Bool
    inside i j = 0 <= i && i < h && 0 <= j && j < w
 
    f :: Int -> Int -> Char
    f i j
      | g !! i !! j == '#' = '#'
      | otherwise          = intToDigit . length . filter (\(ii, jj) -> g !! ii !! jj == '#') $ adj
      where adj = [(ii, jj) | ii <- [i-1..i+1], jj <- [j-1..j+1], inside ii jj]

C 問題

DFS せずに行列でやった。

-- Exec time: 752 ms
-- Memory usage: 10508 KB
import Control.Applicative
import Control.Monad
import Data.List
 
main = do
  [n, m] <- map read . words <$> getLine
  es <- map (map pred . map read) . map words <$> replicateM m getLine
  print . length . filter (isBridge n es) $ es
 
isBridge :: Int -> [[Int]] -> [Int] -> Bool
isBridge n es [u, v] = not . (!! v) . (!! u) . foldl1' mul . replicate n $ toMatrix n (delete [u, v] es)
 
toMatrix :: Int -> [[Int]] -> [[Bool]]
toMatrix n es = [[f i j | j <- [0..n-1]] | i <- [0..n-1]]
  where
    f :: Int -> Int -> Bool
    f i j
      | i == j    = True
      | otherwise = [i, j] `elem` es || [j, i] `elem` es
 
mul :: [[Bool]] -> [[Bool]] -> [[Bool]]
mul a b = [[foldl1' (||) $ zipWith (&&) x y | y <- transpose b] | x <- a]

D 問題

こういうのは書きやすいね。

-- Exec time: 815 ms
-- Memory usage: 2428 KB
import Control.Applicative
import Control.Monad
import Data.List
 
main = do
  [n, k] <- map read . words <$> getLine
  xy <- map (map read) . map words <$> replicateM n getLine
  print $ solve xy k
 
solve :: [[Int]] -> Int -> Int
solve xy k = minimum . map (\(x1, y1, x2, y2) -> (x2 - x1) * (y2 - y1)) . filter ((>= k) . count xy) $ bs
  where
    [xs, ys] = transpose xy
    bs = [(x1, y1, x2, y2) | x1 <- xs, x2 <- xs, y1 <- ys, y2 <- ys, x1 < x2, y1 < y2]
 
count :: [[Int]] -> (Int, Int, Int, Int) -> Int
count xy (x1, y1, x2, y2) = length . filter (\[x, y] -> x1 <= x && x <= x2 && y1 <= y && y <= y2) $ xy

Haskell: codefes 2017 qualB

A 問題

後ろを drop みたいな関数は見つからなかったので reverse で誤魔化した。大半の haskell の提出もこうやっていた。

main = getLine >>= putStrLn . reverse . drop 8 . reverse

iterate init でいい感じの無限リストを作って 8 番目の要素を取る、という手法も考えられる。

main = getLine >>= putStrLn . (!! 8) . iterate init

一行にこだわらなければ他にも方法はあるだろう。

B 問題

Data.MultiSet は標準にないので atcoder では提出できない。

import Control.Applicative
import Data.MultiSet (MultiSet, isSubsetOf, fromList)

main = do
  _ <- getLine
  a <- fromList . map read . words <$> getLine :: IO (MultiSet Int)
  _ <- getLine
  b <- fromList . map read . words <$> getLine :: IO (MultiSet Int)
  putStrLn . yesno $ b `isSubsetOf` a

yesno :: Bool -> String
yesno True = "YES"
yesno False = "NO"

C 問題

グラフの問題は本当につらい。グラフ自体は Vector に変換しておけばいいんだけど、訪問済み頂点の処理は高価なデータ構造を使わないと純粋関数で書くのは難しい。Map でこの手の操作をすると毎回 time limit ギリギリになる。

import Control.Applicative
import Control.Monad
import Data.List
import Data.Array.IO
import qualified Data.Vector as V
import qualified Data.Map as M
import Debug.Trace
 
main = do
  [n, m] <- map read . words <$> getLine
  g <- newArray (0, n - 1) [] :: IO (IOArray Int [Int])
  forM_ [1..m] $ \_ -> do
    [u, v] <- map pred . map read . words <$> getLine
    readArray g u >>= writeArray g u . (v:)
    readArray g v >>= writeArray g v . (u:)
  g' <- V.fromList <$> getElems g
  let (c, f) = testBipartite g'
  let white = length . filter (==True) . map snd . M.toList $ c
  let black = length . filter (==False) . map snd . M.toList $ c
  print $ if f then white*black - m
               else n*(n-1)`div`2 - m
 
testBipartite :: V.Vector [Int] -> (M.Map Int Bool, Bool)
testBipartite = dfs 0 False M.empty
 
dfs :: Int -> Bool -> M.Map Int Bool -> V.Vector [Int] -> (M.Map Int Bool, Bool)
dfs u c m g = foldl' f (M.insert u c m, True) $ g V.! u
  where
    f :: (M.Map Int Bool, Bool) -> Int -> (M.Map Int Bool, Bool)
    f (m, False) _ = (m, False)
    f (m, True) v = case M.lookup v m
                    of Just c' -> (m, c /= c')
                       Nothing -> dfs v (not c) m g

D 問題

以前は IOArray から IOUArray に書き換えるだけで良かった気がするんだけど、使おうと思うと失敗する。DP なのでおとなしく array を使った。ただ依存関係が狭いので fold でも簡単にいける(書いてないけど)。haskell はメモリ消費量の見積もりが難しい。

import Control.Applicative
import Control.Monad
import qualified Data.Vector as V
import Data.Array.IO

main = do
  n <- readLn :: IO Int
  s <- V.fromList <$> getLine

  dp_1101 <- newArray (0, n) (-inf) :: IO (IOArray Int Int)
  dp_1011 <- newArray (0, n) (-inf) :: IO (IOArray Int Int)
  dp_wait <- newArray (0, n) (-inf) :: IO (IOArray Int Int)

  writeArray dp_wait 0 0

  forM_ [0..n-1] $ \i -> do
    when (i+3 <= n && (V.toList . V.slice i 3) s == "101") $ do
      readArray dp_wait i >>= to dp_1011 (i + 3) 1
      readArray dp_1101 i >>= to dp_wait (i + 3) 1
      readArray dp_wait i >>= to dp_wait (i + 3) 1
    when (s V.! i == '1') $ do
      readArray dp_1011 i >>= to dp_1011 (i + 1) 1
      readArray dp_1101 i >>= to dp_1101 (i + 1) 1
      readArray dp_wait i >>= to dp_1101 (i + 1) 1
      readArray dp_1011 i >>= to dp_wait (i + 1) 1
    readArray dp_wait i >>= to dp_wait (i + 1) 0

  readArray dp_wait n >>= print

to :: IOArray Int Int -> Int -> Int -> Int -> IO ()
to a i c v = readArray a i >>= writeArray a i . max (v + c)

inf :: Int
inf = 10^9

Sandy the foodie

https://www.codechef.com/problems/KOK100

euler-tour tree。O(n log n) ではあるけど、定数倍が重くて通らなかった。

euler-tour を考えるとき辺で見るか、頂点で見るかどちらかだと思うけど、辺で考えると対称性が良い気がするので辺で実装している。今回の問題のように頂点に値を持たせる場合は、仮想的な何かを差し込んでおいてそれを使うと良い。

Haskell: DDCC2017 qual

流石に競技中は C++ を使ったけど Haskell で解き直した。

A 問題

main = getLine >>= putStrLn . yesno . solve
 
yesno :: Bool -> String
yesno True = "Yes"
yesno False = "No"
 
solve :: String -> Bool
solve [a, b, c, d] = a == b && b /= c && c == d

B 問題

A 問題の方が本当のプログラミング初心者にとっては難しいのはないだろうか。12 進表記と見なせて foldl が使える。

{-# LANGUAGE ScopedTypeVariables #-}
main = getLine >>= print . foldl1 (\x y -> x*12 + y) . map (read :: String -> Int) . words

C 問題

二分探索で書いた。ソートしてから先頭 x 個を切り出し、all (< c) $ zipWith (+) a (reverse a) ならば OK。

import Control.Monad
import Data.List
 
main = do
  [n, c] <- map read . words <$> getLine
  replicateM n readLn >>= print . (solve c) . sort
 
solve :: Int -> [Int] -> Int
solve c a = let x = binarySearch f 0 (n + 1) in n - x + (x + 1) `div` 2
  where
    n = length a
    f :: Int -> Bool
    f x = let a' = take x a in all (< c) $ zipWith (+) a' (reverse a')
 
binarySearch :: (Int -> Bool) -> Int -> Int -> Int
binarySearch f ok ng
  | ng - ok == 1 = ok
  | otherwise    = let mid = (ok + ng) `div` 2
                   in if f mid then binarySearch f mid ng
                               else binarySearch f ok mid

D 問題

実装をいかにミスらないようにするかが本質の問題だった。初期状態で余分なマスが存在するか否かでスコアが変わるので注意。

import Control.Applicative
import Control.Monad
import Data.List
 
main = do
  [h, w] <- map read . words <$> getLine
  [a, b] <- map read . words <$> getLine
  g <- replicateM h getLine
  print $ solve g a b
 
solve :: [String] -> Int -> Int -> Int
solve g a b = max scoreA scoreB
  where
    scoreA = foo (makeQuad g) a b
    scoreB = foo (makeQuad . transpose $ g) b a
 
foo :: [(Char, Char, Char, Char)] -> Int -> Int -> Int
foo g a b = let (s, d) = foldl' f (0, 10^9) g in s + a + b - d
  where
    f :: (Int, Int) -> (Char, Char, Char, Char) -> (Int, Int)
    f (s, d) (a00, a10, a01, a11)
      | c == 0                               = (s, d)
      | c == 1                               = (s, 0)
      | c == 2 && (a00 == a11 || a10 == a01) = (s, 0)
      | c == 2 && (a00 == a01 || a10 == a11) = (s, 0)
      | c == 2 && (a00 == a10 || a01 == a11) = (s + a, min d a)
      | c == 3                               = (s + a, 0)
      | otherwise                            = (s + a + b + max a b, min d (a + b))
      where c = sum . map toint $ [a00, a10, a01, a11]
      
toint :: Char -> Int
toint 'S' = 1
toint '.' = 0
 
makeQuad :: [String] -> [(Char, Char, Char, Char)]
makeQuad g = zip4 a00 a10 a01 a11
  where
    a00 = concat . quarter $ g
    a10 = concat . quarter . reverse $ g
    a01 = concat . quarter . map reverse $ g
    a11 = concat . quarter . map reverse . reverse $ g
 
quarter :: [String] -> [String]
quarter g = let h = length g; w = length . head $ g
            in take (h `div` 2) . map (take $ w `div` 2) $ g

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