ABC412 A～F をHaskellで

文中の引用は twitter上で行った簡易な解説 by kyopro_friends からです。

A - Task Failed Successfully

問題 ABC412A

シグネチャを決める。横着する。

abc412a :: Int     -- N
        -> [[Int]] -- Ai, Bi
        -> Int     -- 答え
abc412a _ abs = length [() | a:b:_ <- abs, a < b]

なんで目標より多くなんだ。

B - Precondition

問題 ABC412B

シグネチャを決める。

import Data.Char

abc412b :: String -- S
        -> String -- T
        -> Bool   -- 答え
abc412b s t = and [isLower a || elem b t | (a,b) <- zip (tail s) s]

$A \Rightarrow B$ (AならばB) は $\neg A \lor B$ と等しい。

C - Giant Domino

問題 ABC412C

シグネチャを決める。ひとつのテストケースについて処理する。

abc412c :: Int   -- N
        -> [Int] -- Si
        -> Int   -- 答え

イメージとして、小さいドミノから大きすぎるドミノはいきなり倒せないので、
大きさが倍以下のものに繋いでいくその系列が作れるかということ。
今倒せる中で最も大きいものを貪欲に選んでいけばいい。

結果

import qualified Data.IntSet as S

abc412c :: Int -> [Int] -> Int
abc412c _n ss@(s1:_) = loop 2 s1
  where
    sN = last ss
    sS = IS.fromList ss

    loop !cnt a
      | sN <= b   = cnt  -- 目標（以上）を達成
      | b == a    = -1   -- 広げることができないなら不可能
      | otherwise = loop (succ cnt) b -- 繰り返す
      where
        Just b = IS.lookupLE (a + a) sS

$S_1$ より小さいものや$S_N$ より大きいものを除外して IntSet を作ると高速化しそうだが、
探索の手間 $O(\log M)$ の $M$ が小さくなっても大きな効果はないし、
$S_1 > S_N$ のような場合にバグったりするので、慎重さが余計に必要になる。

D - Make 2-Regular Graph

問題 ABC412D

シグネチャを決める。横着する。

abc412d :: Int     -- N
        -> Int     -- M
        -> [[Int]] -- Ai, Bi
        -> Int     -- 答え

考える

目標のグラフの形

単純無向グラフなので自己辺や多重辺はなし。
それで全ての頂点の次数を2にするには、ぐるっとループを作るしかない。
ただし、全員をひとつのループにするだけでなく、小さな（ただし自己ループはなし）ものがたくさん、でもよい。

と言われてもとぎょっとするが、$N \leq 8$ と小さいので、全てを数え上げる。

頂点番号を2つずつ並べたリスト 1,1,2,2,…,n,n を初期値として、未使用の端点を管理する。
リスト先頭を始点として、終点を総当たりで選ぶ。
同じグラフを重複して生成しないように、終点の選択肢は要素の重複を除いてから総当たりする。
先頭要素が重複しているときは、自己ループを防ぐことと、やはり重複を避けるために、両方の分を同時に選ぶ。多重辺にならないようにも気をつける。

計算したいこと

与えられたグラフ $G$ に対して、上で全列挙したグラフと比較して、辺の本数の差を合計した値の最小値を探す。
辺の始点と終点の対を配列の添え字にして、辺があるところに1を入れた配列を用いると、差を計算しやすい。

上の手順を、単にグラフを作ることと捉えて、配列で差を計算してもよいが、
グラフを構築する際の初期値として $G$ の配列を与えて、作成するグラフで辺を張るたびに配列から1を引いていくと、
グラフが完成したときには差が手許にあって、絶対値の総和をとるだけで済む。

結果

import Data.Array.Unboxed
import Data.List

abc412d :: Int -> Int -> [[Int]] -> Int
abc412d n _m uvs = minimum
    [sum $ map abs (elems cand) | cand <- cands]
  where
-- 元々ある辺
    g :: UArray (Int,Int) Int
    g = accumArray (+) 0 ((1,1),(n,n)) [(minMax a b, 1) | a:b:_<- uvs]
-- 次数残りカウントの初期値
    all2 :: [Int]
    all2 = [i | i <- [1 .. n], _ <- [(),()]]
-- 先頭の頂点とその他の頂点で任意に選ぶ。
    cands = gen all2 g []
-- 全て消費できたら候補ができた
    gen [] gr rest = gr : rest
-- 先頭2つが同じ番号のとき、同時に2つ選ぶ
    gen (v1:v2:vs) gr rest | v1 == v2 = foldr ($) rest
      [ gen vs2 gr2
      | u1 <- uniq vs ,           let vs1 = delete u1 vs , let gr1 = accum (+) gr  [(minMax v1 u1, -1)]
      , u2 <- uniq vs1, u2 /= u1, let vs2 = delete u2 vs1, let gr2 = accum (+) gr1 [(minMax v2 u2, -1)]]
-- 違うなら先頭とその他で選ぶ。
    gen (v:vs) gr rest = foldr ($) rest
      [ gen (delete u vs) (accum (+) gr [(minMax v u, -1)])
      | u <- uniq $ delete v vs ]

-- たかだか2つまで、同じ値は必ず続いているリストの内容を一つだけにする
uniq :: [Int] -> [Int]
uniq [] = []
uniq (x:y:xs) | x == y = x : uniq xs
uniq (x:xs) = x : uniq xs

minMax :: Ord b => b -> b -> (b, b)
minMax a b
  | a <= b    = (a, b)
  | otherwise = (b, a)

目標のグラフを作る方法

公式解説、ユーザ解説で色々なやり方が示されている。

• 公式解説では、自己ループも多重辺も許されないことから、サイクルの大きさは3以上であること、$N \leq 8$ なのでサイクルは2つまでしか含まれないことを使っている。また、1からNの順列を、サイクルの頂点の順序とする方法を使っている。
• ユーザ解説 by potato167 では、順列を、関数グラフの辺の伸び先と解釈する方法を提案している。全員がせーので被らないように誰かを指さすイメージ。サイクルの長さ1は出てこないが長さ2は起きうるのでそれを除外する必要がある。
• ユーザ解説 by toam では、探すべきグラフの辺の本数が$N$である（これを握手の補題というらしい。頂点の次数が2なので、辺の両端が$2N$個、それらを辺で繋ぐのには$N$本かかる、ということにすぎないが）こと、$N$頂点の完全グラフの辺$N(N-1)/2$本から$N$本を選ぶやり方を総当たりして、長さ2のサイクルを除外することで列挙できると言っている

ユーザ解説 by sounansya だけ全く違うアプローチで

• 頂点集合の全ての部分集合を作って、それらごとに、元のグラフと極力違わないようにサイクルを張ったときの、共通する辺の本数を求める
• 部分集合を選んで全体を分割する方法全てについて、共通する本数の最大値 K を求める
• すると $N + M - 2K$ が答え
  となっている。

E - LCM Sequence

問題 ABC412E

シグネチャを決める。

abc412d :: Int     -- L
        -> Int     -- R
        -> Int     -- 答え

最小公倍数とはつまり、素因数分解したそれぞれの素数の係数の最大値を持ち寄った値になる。
$1,2,\cdots,n$ の最小公倍数の変化を考えると、末尾の $n$ が素数のべき乗の値になるたびにその係数が+1されて変化する。
素数なので、複数の要因が同時に起きることはない。

$R$以下の素数を実際に列挙しようとすると、その手前の素数を全て生成し出すので計算量が無駄にかかる。
ある値$X$が素数かどうかを判定するだけなら、$\sqrt X$ 以下の素数全てで割り切れないことで判断できる。

そこで、エラトステネスのふるいを二重に使って次のようにする。

• 2から$\sqrt X$までの数について、普通に使って素数を列挙する。見つけた素数を $p_i$ とする。
• $L+1$から$R$までの数について、
  • 上のふるいの続きで、$p_i$ の倍数 $p_i^2, p_i(p_i + 1), \dots$ を全て落とす。それらは合成数である
    （ここで印が付けられなかった数は素数（の1乗）なので、探している数である）
  • ただし、$p_i$ のべき乗の数については、合成数であっても拾うべきなので復活させる

結果

エラトステネスのふるいは配るDPだ！ということで、前回ABC411Gで作った配るDP関数を使った。
$L$から$R$の範囲の広範のふるいについて sv2 を accumArray で作ってから sv3 で accum している。
これを同時にやろうとすると、作り方の違うリストの連結に時間がかかり、微妙にTLEする。

import Control.Monad.ST
import qualified Data.Vector.Unboxed.Mutable as MUV
import qualified Data.Vector.Unboxed as UV
import Data.Array.Unboxed

abc412e :: Int -> Int -> Int
abc412e l r = succ $ length $ filter id $ tail $ elems sv3
  where
-- √R
    rR = iSqrt r
-- 2～√Rの範囲について、エラトステネスのふるいで素数を見つける
    sv1 = distribute (2, rR) True const [] svF
    svF i _ = [(k, False) | k <- [i * i, i * succ i .. rR]]
-- L～R の範囲について、
-- 1.
-- エラトステネスのふるいで素数を見つける
-- つまり sv1 の素数の全てについて、倍数を合成数と印づける
-- 2.
-- √R以下の全ての素数pについて、p^k な値を見つける
-- それら全てに印を付け直す 指数的に増えるので線形探索で十分
    sv2 :: UArray Int Bool
    sv2 = accumArray (flip const) True (l, r) $
          [ (j, False)
          | (p, True) <- assocsPA sv1
          , let k = divrup l p * p
          , j <- [k, k + p .. r] ]
    sv3 = accum (flip const) sv2
          [ (pp, True)
          | (p, True) <- assocsPA sv1
          , pp <- takeWhile (r >=) $ dropWhile (l >) $ iterate (p *) p]

divrup :: Int -> Int -> Int
divrup x y = negate $ div (negate x) y

iSqrt :: Int -> Int
iSqrt n = foldr step 0 $ take 32 $ iterate (2 *) 1
  where
    step b c = let bc = b + c in if bc <= div n bc then bc else c

-- 擬似配列

data PArray i a = PArray (i,i) (UV.Vector a) deriving Show

assocsPA :: (Ix i, UV.Unbox a) => PArray i a -> [(i, a)]
assocsPA (PArray bnds vec) = zip (range bnds) (UV.toList vec)

-- 配るDPを実行する
distribute :: (Ix i, MUV.Unbox a)
           => (i, i)              -- 添え字の範囲
           -> a                   -- 配列のデフォルト値
           -> (b -> a -> a)       -- 配られた値を足し込む演算
           -> [(i, a)]            -- 計算の種になる初期値
           -> (i -> a -> [(i,b)]) -- 添え字と確定した値を使って、さらに配る先と配る値のリストを作る関数 配る先は現在位置より後方限定
           -> PArray i a          -- 結果 擬似配列
distribute bnds zero add inis f = runST $ do
  vec <- MUV.replicate (rangeSize bnds) zero
  mapM_ (\(i, a) -> MUV.write vec (index bnds i) a) inis
  mapM_ (\i -> do
    v <- MUV.read vec (index bnds i)
    mapM_ (\(j,u) ->
      MUV.modify vec (add u) (index bnds j)
      ) (f i v)
    ) (range bnds)
  PArray bnds <$> UV.freeze vec

区間篩？

アライグマ「E問題は区間篩なのだ！　A[i-1]≠A[i]になるのは、iが素数ベキのときなのだ。だからLからRまでを区間篩で素因数分解すればいいのだ！」

…それ何？
公式解説もABC227Gの公式解説に丸投げしているけど、「連続する整数を全員一斉に素因数分解する」もののようで、自分の解法は、その中で問題の答えに関係する部分だけを抜き出したような、汎用性のない変種、という感じだろうか。

F - Socks 4

問題 ABC412F

シグネチャを決める。

abc412f :: Int   -- N
        -> Int   -- C
        -> [Int] -- Ai
        -> Int   -- 答え

考える

タンスに入っている、2枚めを抽選するときの靴下の枚数という母数を $W$ とする。
$W =\sum A_i$

色 $C$ についても総数を数えるように、$A'[C] = A_C + 1, A'[i] = A_i \ (i \neq C)$ とおき、また、降順に添え字を振り直したものを以降は $A[i]$ と呼ぶ。

手許に色 $x$ の靴下ひとつがあるとき、
$x$ より枚数の多い色 $k < x$ の靴下を取り出す確率は $\displaystyle \frac{A[k]}{W}$
そうなったとき、色 $k$ に取り替えて続けるだろう。

色 $x$ をもう一枚取り出す確率は $\displaystyle \frac{A[x] - 1}{W}$
このとき試行は完了する。

$x$ より枚数の少ない色 $x < j$ の靴下を取り出す確率は $\displaystyle\frac{A[j]}{W}$
そうなったとき、色 $x$ を残して同じ状況でやり直すだろう。

よって、色$x$が手許にあるときの試行回数の期待値 $E[x]$ は

$\displaystyle E[x] = 1 + \sum_{k < x} \frac{A[k]}{W} \cdot E[k] + \frac{A[x] - 1}{W} \cdot 0 + \sum_{x < j} \frac{A[j]}{W} \cdot E[x]$

式変形して $E[x]$ についてまとめると
$E[x] = \big (W + \sum_{k < x} A[k] \cdot E[k] \big ) / \big ( W - \sum_{x < j} A[j] \big)$

となる。

この分子は
$C[x] = W + \sum_{k < x} A[k] \cdot E[k]$
とおくと
$C[1] = W$
$C[x] = C[x-1] + A[x-1]E[x-1]$
と、$E[x-1]$を使って順に値を定められる。

同様に分母は
$D[x] = W - \sum_{x < j} A[j]$
とおくと、$\sum A[i] = W + 1$ であることに注意すると
$D[x] = \sum_{i \leq x} A[i] - 1$
となり、$A[x]$ の累積和から1を引いた値でしかない。

命令型言語なら、元の色 $C$ のソート後の添え字までこれらの値を順に求めるループで計算できるだろう。
Haskellでは、$E[x]$ と $C[x]$ が相互参照する遅延配列を張って計算できる。

結果

import Data.Array

abc412f :: Int -> Int -> [Int] -> Int
abc412f n c as = head [ei | (ei, ai) <- zip (elems eA) (elems aA), ai == ac]
  where
    w = sum as
    c1 = pred c
    ac = succ $ as !! c1
-- 降順の枚数リスト
    aA = listArray (1,n) $ sortBy (flip compare) $ take c1 as ++ ac : drop c as
-- D[x] = [A(1) - 1, WD(x-1) + A(x), ...]
    dA = listArray (1,n) $ tail $ scanl add (-1) $ elems aA
-- C[x] = [W, C(x-1) + A(x-1) E(x-1), ...]
    cA = listArray (1,n) $ w : [add (cA ! i) $ mul (aA ! i) (eA ! i) | i <- [1 .. pred n]]
-- Ex = [ C(x) / D(x) ]
    eA = listArray (1,n) [mul (cA ! i) $ modRecip (dA ! i) |i <- [1 .. n]]

-- モジュロ演算は省略

感想

アライグマ「F問題はDPなのだ！

ということだが、単に $N$ 次元連立方程式を解く問題で、$A$の降順で順に解を算出できる手順があるという性質が利用できた、というだけに見える。

上の解答は遅延配列による集めるDPに似ているが、そのような配列を使わずにループで計算するようにもできる。

abc412f :: Int -> Int -> [Int] -> Int
abc412f _n c as = head [ei | (ai, ei) <- zip aA eA, ai == ac]
  where
    w = sum as
    c1 = pred c
    ac = succ $ as !! c1
-- 降順の枚数リスト
    aA = sortBy (flip compare) $ take c1 as ++ ac : drop c as
-- D[x] = [A(1) - 1, WD(x-1) + A(x), ...]
    dA = tail $ scanl add (-1) aA
-- C[x] = [W, C(x-1) + A(x-1) E(x-1), ...]
-- E[x] = [ C(x) / D(x) ]
    (_, eA) = mapAccumL step w $ zip aA dA
    step ci (ai, di) = (cj, ei)
      where
        ei = mul ci $ modRecip di
        cj = add ci $ mul ai ei

G - Degree Harmony

アライグマ「G問題はグラフ理論なのだ。

ひぃ。