A - G1
シグネチャを決める。
abc410a :: Int -- N
-> [Int] -- Ai
-> Int -- K
-> Int -- 答え
abc410a _n as k = length $ filter (k <=) as
$A_i$ のうち $K$ がそれ以下であるもの、つまり $K$ 以上のものの個数を答える。
B - Reverse Proxy
シグネチャを決める。
abc410b :: Int -- N
-> Int -- Q
-> [Int] -- Xi
-> [Int] -- 答え
指示どおりにするだけ。
命令型配列が前提の内容だが、要素数はたかだか100個なのでimmutable arrayでごり押しする。
結果
import Data.List
import Data.Array.Unboxed
import Data.Tuple
abc410b :: Int -> Int -> [Int] -> [Int]
abc410b n _q xs = snd $ mapAccumL step arr0 xs
where
arr0 :: UArray Int Int
arr0 = listArray (1,n) $ repeat 0
step arr 0 = (arr // [(x, succ cmin)], x)
where
(cmin, x) = minimum $ map swap $ assocs arr
step arr x = (accum (+) arr [(x,1)], x)
C - Rotatable Array
シグネチャを決める。
abc410c :: Int -- N
-> Int -- Q
-> [[Int]] -- Query_i
-> [Int] -- 答え
またも命令型配列。
添字を0始まりにずらして考える。
回転させる代わりに、0とする起点をずらす。タイプ1,2のクエリもそのオフセットを意識してアクセスする。
結果
import Control.Monad
import Data.Array.ST
import Control.Monad.ST
abc410c :: Int -> Int -> [[Int]] -> [Int]
abc410c n q qus = runST $
do
a <- newListArray (0, pred n) [1 .. n] :: ST s (STUArray s Int Int)
r <- newArray (1, q) 0 :: ST s (STUArray s Int Int)
foldM_ (step a r) 0 $ zip [1 ..] qus
filter (0 <) <$> getElems r
where
addr ofs p = mod (pred p + ofs) n
step a _ ofs (_, 1:p:x:_) = writeArray a (addr ofs p) x >> return ofs
step a r ofs (i, 2:p:_ ) = readArray a (addr ofs p) >>= writeArray r i >> return ofs
step _ _ ofs (_, 3:k:_ ) = return (mod (ofs + k) n)
状態の変化も伝える、結果も出力する、という計算を、純粋なら mapAccumL で書くが、状態モナドの場合にいつも困る。
クエリ番号を添字にして答えを書き留める配列で対応してみた。
D - XOR Shortest Walk
シグネチャを決める。横着する。
abc410d :: Int -- N
-> Int -- M
-> [[Int]] -- Ai,Bi,Wi
-> Int -- 答え
ABC408Eでなんか似たような話を見たばっかりな気がするが、逆にそれは罠。
こちらは有向グラフでXOR演算、あちらは無向グラフでOR演算と違って、アプローチも異なる。
$W_i < 2^{10}$ と小さいため、結果の変動範囲も同じく $[0, 2^{10} = 1024)$ でしかない。
さらに $N \leq 1000$ なので、「1から頂点iまでの結果が$x$であるwalkを確認した」というフラグの総数は $10^6$ 程度しかなく、
「頂点1までの結果が0であるwalkを確認した」から始め、辺によりそれを拡散する手順も、最大でこのフラグ全てを立てたら終わる。
なので、ひたすらグラフを辿る手順を繰り返せばできる。
結果
import Control.Monad.ST
import Data.Array.ST
import Data.Array
import Data.Bits
abc410d :: Int -> Int -> [[Int]] -> Int
abc410d n _m abws = runST $
do
f <- newArray ((1,0),(n,ub)) False :: ST s (STUArray s (Int,Int) Bool) -- 頂点vに到達したXOR値
loop f [(1, 0)]
head . (++ [-1]) . map fst . filter snd . zip [0 ..] <$> forM [0, ub] (\i -> readArray f (n, i))
where
ub = 2^10 - 1
-- グラフ
g = accumArray (flip (:)) [] (1,n) [(a,(b,w)) | a:b:w:_ <- abws]
-- ひたすら探索する
loop _ [] = return ()
loop f (ux@(u,x):uxs) = do
fux <- readArray f ux
if fux then loop f uxs else do
writeArray f ux True
loop f $ [(v, xor w x) | (v,w) <- g ! u] ++ uxs
E - Battles in a Row
シグネチャを決める。横着する。
abc410e :: [Int] -- N,H,M
-> [[Int]] -- Ai,Bi
-> Int -- 答え
初期状態 $S_0 = {(H,M)}$ から始め、それぞれのモンスターに対して
$S_i = {(h - A_i, m) \ |\ (h,m) \in S_{i-1}, h \geq A_i} \cup {(h, m - B_i) \ |\ (h,m) \in S_{i-1}, m \geq B_i}$
と可能な状態全てを追跡すると、負の値になって脱落する分と重複する分を無視して $2^N$ になり大変なことになる。
というのは嘘で、可能な状態の個数は $(H+1)(M+1)$ しかなくぎりぎり可能なようにも見えるが、この大きさのフラグ配列を$N$回走査すると $O(HMN)$ で大きすぎる。
可能な状態に ${h,m}$ が存在するとき、${h, m-x}$ は残す必要がない。
二次元のフラグ配列の代わりに、各 $h$ の値ごとに、フラグの立つ最大の $m$ の値を管理する。
結果
import Data.Array.Unboxed
abc410e :: [Int] -> [[Int]] -> Int
abc410e [n,h,m] abs = loop arr0 $ zip [0 ..] abs
where
arr0 :: UArray Int Int
arr0 = accumArray (flip const) (-1) (0, h) [(h, m)]
loop _ [] = n
loop arr ((k, a:b:_):kabs)
| cont = loop arr1 kabs
| otherwise = k
where
arr1 = accumArray max (-1) (0, h) $
[(h - a, m) | (h,m) <- assocs arr, h >= a] ++
[(h, m - b) | (h,m) <- assocs arr, m >= b]
cont = any (0 <=) $ elems arr1
F - Balanced Rectangles
シグネチャを決める。一つ分の計算を考える。大量なので ByteString で受け取る。
abc410f :: Int -- H
-> Int -- W
-> [BS.ByteString] -- Si
-> Int -- 答え
自分の考え
二次元配列に、文字 # があるマスには $1$、. のマスには $0$ を入れるとする。長方形領域の範囲の合計が # の個数、縦横の長さからそれを引くと . の個数もわかるので、それが等しくなる領域を見つける。
…とやると、今考えている領域の広さを常に持っておく必要があって都合が悪い。
. のマスに$0$でなく$-1$を入れるようにすると、バランスしている領域は合計が0になるので、大きさを扱わなくてよくなる。
これで考える。
二次元配列の任意の領域の合計を素早く求めるには、二次元累積和を用いる。
マス $(1,1)$ から $(a,b)$ までの合計を $S(a,b)$ とする。
$(u,l)$ から $(d,r)$ までの合計は $S(d,r) - S(d,l) - S(u,r) + S(u,l)$ で得られる。
これが0になる $(u,l)$ と $(d,r)$ の組み合わせを知りたい。
$S(d,r) - S(d,l) - S(u,r) + S(u,l) = 0$ 移項して
$S(d,r) - S(u,r) = S(d,l) - S(u,l)$
$F(u,d,x) = S(d,x) - S(u,x)$ とおくと、この式は
$F(u,d,l) = F(u,d,r)$ となる。
つまり、任意の $1 \le u < H, u < d \leq H$ に関して、
$F(u,d,L) = F(u,d,R)$ を満たす $1 \leq L \leq R \leq W$ の組を探したい。
$u,d$ は総当たりすることにして一旦固定して考える。
$L,R$ の組を探すのには、総当たりするのではなく、
$F(u,d,x)$ を $1 \leq x \leq W$ について全て求め、
全ての値について $y = F(x)$ となる $x$ の個数 $k_y$ を数え、$k_y(k_y-1)/2$ の総和が答えになる。
$u,d$ については総当たりするしかないので、これをなるべく減らすために、$H > W$ のとき転置して考える。
$F(x)$ の値の範囲は $[-HW, HW]$ である。これはかなり大きな値になりうるが、
一度に考える値の個数は $W$ 個である。
結果
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as UV
import qualified Data.IntMap as IM
abc410f :: Int -> Int -> [BS.ByteString] -> Int
abc410f h w bss
| h <= w = sub h w sN
| otherwise = sub w h sT
where
c2i '#' = 1
c2i _ = -1
-- そのまま累積和を作る
sN = V.scanl (UV.zipWith (+)) (UV.replicate (succ w) 0) $ V.fromListN h $
map (UV.scanl (+) 0 . UV.fromListN w . map c2i . BS.unpack) bss
-- 転置して累積和を作る
sT = V.scanl (UV.zipWith (+)) (UV.replicate (succ h) 0) $ V.fromListN w $
[UV.scanl (+) 0 $ UV.fromListN h [c2i $ BS.index bs i | bs <- bss] | i <- [0 .. pred w]]
-- 本編
sub :: Int -> Int -> V.Vector (UV.Vector Int) -> Int
sub h w s = sum [compute u d | u <- [0 .. pred h], d <- [succ u .. h]] -- u,d は総当たり
where
f u d x = s V.! d UV.! x - s V.! u UV.! x
-- F(u,d,x) の値の個数を数える
compute u d = sum $ map tri $ IM.elems $ IM.fromListWith (+) [(f u d x, 1) | x <- [0 .. w]]
tri k = div (k * pred k) 2
ACx36, TLEx7 となった。
改善
よく見ると、compute と f の間でしている計算は pointwise の引き算なので、
UV.zipWith (-) (s V.! d) (s V.! u) に過ぎない。
また、公式解説にあった種明かしだが、f u d x の値の個数を数える処理を、IntMap のような1アクセス $O(\log W)$ かかるやり方では、この係数のためにTLEするという。
これを1アクセス $O(1)$ で実行するためには命令型配列を使うしかない。
（読みやすさのためにあえて Array.ST で書く。実際には MVector で添字にオフセット $HW$ をかけて対処するべき）
また「全てカウントしてから $k(k-1)/2$」の代わりに、「値に遭遇するたびに $k-1$ を足し合わせ」にしている。
import qualified Data.Array.ST
import Control.Monad.ST
compute u d = count $ UV.zipWith (-) (s V.! d) (s V.! u)`
count fv = runST $ do
cnt <- newListArray (- h * w, h * w) 0 :: ST s (STUArray s Int Int)
sum <$> UV.forM fv (\x -> do
c <- readArray cnt x
writeArray cnt x $ succ c
return c
)
しかしカウント配列の添字が $[-HW, HW]$ と広大で、毎回 cnt を初期化すると逆に大変な時間がかかってしまう。
つまりこの処理を compute から呼び出す部分関数の count で閉じた処理にはできず、
使い終わった後に、使った部分だけ0クリアし直して、全ての実行について再利用するスタイルにする必要がある。
とはいえ、sub の上から下まで全てを ST モナドで一体化させるのはつらい。
sub → compute → count という呼び出し関係だけで考えると行き詰まった。
count に渡す一つ一つの fv を並べたリストを作る処理と、リストで送り込まれる fv のリストを次々に処理する ST モナド部分、という構造に分割することで、プログラムの改変を小規模に留めることができる。
最終結果
全体はこちら482ms, 94MiB
import qualified Data.Vector.Unboxed.Mutable as MUV
import Control.Monad.ST
sub :: Int -> Int -> V.Vector (UV.Vector Int) -> Int
sub h w s = countEm (h * w) [UV.zipWith (-) (s V.! d) (s V.! u) | u <- [0 .. pred h], d <- [succ u .. h]]
countEm :: Int -> [UV.Vector Int] -> Int
countEm hw vs = runST $ do
cnt <- MUV.new (hw + succ hw) :: ST s (MUV.MVector s Int)
flip div 2 . sum <$> forM vs (\v -> do
UV.mapM_ (\x -> MUV.modify cnt succ (x + hw)) v
UV.foldM' (\acc x -> do
y <- MUV.read cnt (x + hw)
if y == 0 then return acc else do
MUV.write cnt (x + hw) 0
return $ acc + y * pred y -- ← ココ！
) 0 v
)
「全てカウントしてから $k(k-1)$ を全て足し合わせてから $/2$」にした。
なお、countEm 内部の UV.foldM' をstrictにし忘れると、結果の足し算がスペースリークを起こしてTLE/MLEする。
考察
- 上の最終版は、
countEmにSTモナドが仕方なくある以外はimmutableに書けた。 -
Data.Vector,Data.Vector.Unboxedはimmutableながら、foldなどもできて、うまく使うと速い。 -
countからcountEmへの構造の変更は、何かデザインパターンっぽい？
公式解説について
ひとに見せるものなのだがら、もうちょっとprettifyした方がよかないですか。最密充填リストじゃないんだから。
L.39からの、「横に累積和をhでとりつつ、+ofsした値でbkにアクセス」の部分、累積和の初期値をofsにしたら少し短くなる。
（まさか最近のCコンパイラは勝手にそうする、なんてことは？）
int h;
h = ofs;
bk[h]++;
for (int i = 0; i < W; i++) {
h += C[i];
res += bk[h];
bk[h]++;
}
// reset bk
h = ofs;
bk[h] = 0;
for (int i = 0; i < W; i++) {
h += C[i];
bk[h] = 0;
}
公式解説のやり方は自分のアイデアと方針が異なるように見えるが、実際には大きな違いはない。
グリッドを保持する配列には $1, -1$ だけが格納され、毎回、注目している箇所の二次元累積和を求めている点が異なる。
この中で、$W$ 方向の累積は先にやっておく方がよいと思われる。
$H$ 方向の累積は、
- 自分のアイデアでは $u,d$ の対について毎回引き算をしている
- 公式解説では $u$ の行から始めて累積和を求めている
で、計算量は同じ、というか先行して行方向の累積和をとっている自分の方がその分の計算量が余計にかかっている。
累積和を$W$方向だけ求めておき、$H$方向の累積和は sub で毎回求める変更をすると次のようになる。
abc410f h w bss = ...
where
...
-- そのまま横累積和を作る
sN = V.fromListN h $
map (UV.scanl (+) 0 . UV.fromListN w . map c2i . BS.unpack) bss
-- 転置して横累積和を作る
sT = V.fromListN w $
[UV.scanl (+) 0 $ UV.fromListN h [c2i $ BS.index bs i | bs <- bss] | i <- [0 .. pred w]]
sub :: Int -> Int -> V.Vector (UV.Vector Int) -> Int
sub h w s = countEm (h * w) $ concatMap f [0 .. pred h]
where
f u = scanl (UV.zipWith (+)) (s V.! u) (V.toList $ V.drop (succ u) s)
G - Longest Chord Chain
シグネチャを決める。横着する。
abc410g :: Int -- N
-> [[Int]] -- Ai,Bi
-> Int -- 答え
Fで力尽きたので解説を見た。
公式解説のやり方は、ある位置$x$で切ったとき、$x$未満の区間について最長減少部分列で数え、$x$以上の区間についても同様にして負担なく数えることができる、ということらしい。
自分流にやるなら、$x$ 以上の区間については、反対向きに考えて、未満と同じ計算をして、対応する$x$どうしの答えの和の最大値を探す、という風にするだろうか。
ユーザ解説 by MMNMM は、周回を処理するために円を倍に膨らませると、最長減少部分列を数える計算だけで答えが得られるというアイデア。これはコードが楽ちんでいいので、これを採用する。
結果
ソートは $O(N \log N)$でなく配列バケツソートで $O(N)$ にする。
最長増加部分列を数えるルーチンをそのまま使うために、値をマイナスにして与える。
import Data.List
import Data.Array.Unboxed
import qualified Data.IntSet as IS
abc410g :: Int -> [[Int]] -> Int
abc410g n abs =
lengthLIS $ filter (0 >) $ elems $
(accumArray (flip const) 0 (1, n * 4) $
[(a, negate b) | x:y:_ <- abs, let a = min x y, let b = max x y] ++
[(b, negate $ n2 + a) | let n2 = n + n, x:y:_ <- abs, let a = min x y, let b = max x y] :: UArray Int Int)
lengthLIS :: [Int] -> Int
lengthLIS [] = 0
lengthLIS xs = snd $ foldl' step (IS.empty, 0) xs
where
step st@(is, len) xi =
case IS.lookupGT xi is of
Nothing -> (IS.insert xi is, succ len)
Just y | xi == y -> st
| otherwise -> (IS.insert xi $ IS.delete y is, len)