Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

This article is a Private article. Only a writer and users who know the URL can access it.
Please change open range to public in publish setting if you want to share this article with other users.

ABC091をHaskellで

Posted at

A - Two Coins

問題 ABC091A

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

abc091a :: [Int] -- A,B,C
        -> Bool  -- 答え
abc091a [a,b,c] = a + b >= c

B - Two Colors Card Game

問題 ABC091B

シグネチャを決める。

abc091b :: Int -- N
        -> [String] -- s_i
        -> Int -- M
        -> [String] -- t_i
        -> Int -- 答え

青のカードにある語のみが、正のスコアを得る可能性がある。
例3のように、どの語を選んでも負になる場合、全く出現していない語をでっちあげることで0点にする。

結果

語ごとのスコアを Map String Int で数え、最大値を選ぶ。

import qualified Data.Map as M

abc091b :: Int -> [String] -> Int -> [String] -> Int
abc091b _n ss _m ts = maximum $ 0 : M.elems m
  where
    m :: M.Map String Int
    m = M.fromListWith (+) $ [(s,1) | s <- ss] ++ [(t,-1) | t <- ts]

C - 2D Plane 2N Points

問題 ABC091C

シグネチャを決める。

abc091c :: Int -- N
        -> [[Int]] -- a_i, b_i
        -> [[Int]] -- c_i, d_i
        -> Int -- 答え

全体としてX座標を小さい方から順に考える。
現在注目しているX座標にある赤い点は、X座標的にはこれ以降に考える青い点とペアにしてよいので記録しておく。
その後、現在注目しているX座標にある青い点について考える。
記録されている赤い点は全てX座標がより小さいものなので、Y座標についても自分より小さいもののうちで最大の赤い点をペアに貪欲に選び、取り除く。そのような赤い点が見つからない青い点は捨てる。
最後までペアにならず残った赤い点の個数をNから引いたら、ペアのできた数になる。

結果

X座標はぴっちぴちに詰まっているので、ソートする代わりにバケツソートとして配列の添字をX座標にする。
配列の要素がY座標になるが、青い点を見分けるために、$-(d+1)$ という負の値で青い点を表すことにする。
Y座標も全て異なるので、重複を気にせず IntSet で管理できる。

import Control.Monad
import qualified Data.IntSet as IS
import Data.List
import Data.Array.Unboxed

abc091e :: Int -> [[Int]] -> [[Int]] -> Int
abc091e n abs cds = n - IS.size (foldl' step IS.empty $ elems arr)
  where
    arr :: UArray Int Int
    arr = array (0, n + pred n) $ -- 点をX座標の順にソート
         [(a, b) | (a:b:_) <- abs] ++
         [(c, negate $ succ d) | (c:d:_) <- cds]

step s b | b >= 0 = IS.insert b s -- 赤い点は記録に加える
step s nd =
  case IS.lookupLT d s of
    Nothing -> s
    Just b  -> IS.delete b s -- 青い点に対応させる赤い点が見つかったら除く
  where
    d = pred $ negate nd

D - Two Sequences

問題 ABC091D

シグネチャを決める。

abc091d :: Int -- N
        -> [Int] -- a_i
        -> [Int] -- b_i
        -> Int -- 答え

愚直にやると当然 $O(N^2)$ で間に合わない。
上手いことやろうとしても、3秒の時間制限がかなり厳しかった。
最終的にどうにかできたので、記録を残す。

基本方針

$a_i, b_j < 2^{28}$ なので、和の可能な最大値は $(2^{28}-1) \times 2 = 2^{29} - 2$
0から数えて29ビットめまでを考えればよい。
和をビットごとに考えて、ビット$k$が1になるような和の個数が奇数のとき答えのビット$k$も1になる。

和のビット$k$がどうなるかは、$a_i, b_j$ のビット$k$以下だけから決まるので、そこより上はマスクして無視する。
マスクされた $b_j$ の多重集合に対して、マスクされた $a_i$ と足した結果のビット $k$ が1になるような $b_j$ の値の範囲は $2^k - a_i \leq b_j < 2^{k+1} - a_i$ である。
この範囲に当てはまる $b_j$ の個数は、二分探索や Map で $O(\log N)$ で数えられる。

よって全体的なアルゴリズムは次のようになる。

  • 注目するビット $k$ を0から29までそれぞれ計算する
    • 全ての $b_j$ のビット $k$ より上をマスクし、ソートして配列に収める
    • $a_i$ のそれぞれについて、$[2^k - a_i, 2^{k+1} - a_i)$ の範囲にある $b_j$ の個数を数える
    • 個数の合計が奇数なら、答えのビット $k$ は1

ここで、範囲 $[2^k - a_i, 2^{k+1} - a_i)$ は $a_i$ の値によっては0を下回る範囲を含む。
これは反対側にwrap-aroundさせる必要がある。
つまり、

  • $2^k \leq a_i$ のときは、定義どおり $[2^k - a_i, 2^{k+1} - a_i)$
  • そうでないとき、回り込んで $[0, 2^{k+1} - a_i) \cup [2^k - a_i + 2^{k+1}, 2^{k+1})$

とする。

さらなる改良

上の節の方針までで、C++などでは間に合う実装が可能なようだが、Haskellではまだなかなかきつく、
mutable vector などでごりごりと書くことでどうにかACする、といった状況のようだ。

手順の中の「マスクした $b_j$ をソートする」ところに注目する。
$k = 29$ のとき、マスクは無意味で、単に $b_j$ をソートすればよい。
あるビット $k+1$ のためのソート済み配列があるとき、ビット $k$ のためのこの配列は、

  • 前半の、ビット $k$ が0な区間はそのまま
  • 後半の、ビット $k$ が1な区間はそのビットを0にして

マージソートのマージを行うことで $O(N)$ で構築できる。
また、後半の開始位置を探す計算も、線形探索で横着せず、二分探索で真面目に探す。

import Data.List
import qualified Data.Vector.Unboxed as UV
import Data.Bits

abc091d :: Int -> [Int] -> [Int] -> Int
abc091d n as bs = fst $ foldl' step (0, bv0) [29, 28 .. 0]
  where
    bv0 = UV.fromListN n $ sort bs
    step :: (Int, UV.Vector Int) -> Int -> (Int, UV.Vector Int)
    step (ans, bv) k = (ans1, bv3)
      where
        (_,h) = binarySearch (\i -> testBit (bv UV.! i) k) (-1) n
        (bv1, bv2) = UV.splitAt h bv
        bv3 = UV.fromListN n $ merge (UV.toList bv1) (map (flip clearBit k) $ UV.toList bv2)
        lb = bit k
        ub = bit (succ k)
        mask = bit (succ k) - 1
        count = sum
          [ if lb >= a then q - p else pred q + pred n - u
          | a <- map (mask .&.) as
          , let p = lookupLTindex (lb - a) bv
          , let q = lookupLTindex (ub - a) bv
          , let u = lookupLTindex (lb + ub - a) bv
          ]
        ans1 = if odd count then setBit ans k else ans
    lookupLTindex x vec = snd $ binarySearch (\i -> vec UV.! i < x) n (-1)

merge xxs@(x:xs) yys@(y:ys) =
  case compare x y of
    LT -> x : merge xs yys
    GT -> y : merge xxs ys
    EQ -> x : y : merge xs ys
merge [] ys = ys
merge xs [] = xs

binarySearch :: (Int -> Bool) -> Int -> Int -> (Int, Int)
binarySearch prop unsat sat = loop unsat sat
 where
   loop a b
     | ende   = (a, b)
     | prop m = loop a m
     | True   = loop m b
     where
       ende = a == m || b == m
       m = div (a + b) 2

結果:1634ms

immutableな計算を使わない、(僕の考える)Haskellらしいコードでこのタイムが達成できて満足。

0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?