ABC300 A～E をHaskellで

# A - N-choice question

[問題 ABC300A](https://atcoder.jp/contests/abc300/tasks/abc300_a)

シグネチャを決める。

```haskell
abc300a :: Int   -- N
        -> Int   -- A
        -> Int   -- B
        -> [Int] -- Ci
        -> Int   -- 答え
```

正解となる選択肢は必ず一つだけ存在する、と保証されているので、それを探せばよい。

## 結果

```haskell
abc300a n a b cs = head [i | (c,i) <- zip cs [1..], c == a + b]
```
# B - Same Map in the RPG World

[問題 ABC300B](https://atcoder.jp/contests/abc300/tasks/abc300_b)

シグネチャを決める。

```haskell
abc300b :: Int       -- H
        -> Int       -- W
        -> [String]  -- Aij
        -> [String]  -- Bij
        -> Bool      -- 答え
```

大した大きさではないので、全てのずらし量に関して試してみてもよい。
幅の上限30は、32ビット整数にビット列で入れても間に合う大きさで、その方が比較が高速にできる。

リストを回転させてどこかで一致するかを探す `prop` は、
```haskell
prop xs ys = not $ null
  [ ()
  | d <- [0..pred $ length xs]
  , let (as,bs) = splitAt d xs
  , bs ++ as == ys
  ]
```
と書けるが、つまり、(`xs`,`ys`の長さを`l`、ずらし量を`d`として）
- `ys`の前方が`drop d xs`と等しい
- `xs`の前方が`drop (l-d) xs`と等しい

ということなので、`isPrefixOf` により `(++)` を消せる。

## 結果

```haskell
import Data.Bits
import Data.List

abc300b :: Int -> Int -> [String] -> [String] -> Bool
abc300b h w ass bss = any prop $ take w $ iterate (map (rot w)) ans
  where
    ans = map s2b ass
    bns = map s2b bss
-- リストを0～h-1回転させるとbssと一致
    prop xs = not $ null
      [ ()
      | d <- [0..pred h]
      , isPrefixOf (drop d xs) bns
      , isPrefixOf (drop (h-d) bns) xs
      ]

-- 一行の文字列をビット表現に変換
s2b :: String -> Int
s2b = foldl step 0
  where
    step x c = shiftL x 1 .|. if c == '#' then 1 else 0

-- 幅Wのビット列を1ビット右回転
rot :: Int -> Int -> Int
rot w n = shiftR (if even n then n else setBit n w) 1
```

# C - Cross

[問題 ABC300C](https://atcoder.jp/contests/abc300/tasks/abc300_c)

シグネチャを決める。

```haskell
abc300c :: Int       -- H
        -> Int       -- W
        -> [String]  -- Cij
        -> [Int]     -- 答え
```

素直にグリッドの様子を二次元配列に入れておき、
全てのグリッドをバツ印の中心と仮定して、その大きさを測定した結果を大きさごとにカウントする。

## 結果

```haskell
import Data.Array

abc300c :: Int -> Int -> [String] -> [Int]
abc300c h w css = elems cnts
  where
-- グリッドの内容
    g = listArray ((1,1),(h,w)) [c == '#' | cs <- css, c <- cs]
-- 添え字がはみ出しても大丈夫なgのアクセサ
    f i j = 0 < i && i <= h && 0 < j && j <= w && g ! (i, j)
-- 全ての位置についてバツ印の大きさを測った結果をカウントする
    cnts = accumArray (+) 0 (1, min h w)
           [ (s, 1)
           | i <- [1..h], j <- [1..w]
           , let s = size i j, s > 0]
-- 中心i,jのバツ印の大きさを測る
    size i j
      | not $ f i j = 0
      | otherwise = loop i j 1
    loop i j d
      | grow      = loop i j (succ d)
      | otherwise = pred d
      where
        grow = f (i-d) (j-d) && f (i-d) (j+d) &&
               f (i+d) (j-d) && f (i+d) (j+d)
```

# D - AABCC

[問題 ABC300D](https://atcoder.jp/contests/abc300/tasks/abc300_d)

シグネチャを決める。

```haskell
abc300d :: Int  -- N
        -> Int  -- 答え
```

$i$ 番目の素数を $p_i$ と表す。

素因数分解して $a^2 \cdot b \cdot c^2 \  (a < b < c)$ となる数の個数、ということなので、異なる$a,b,c$の組に関して重複する心配はない。素直に数えればよい。
$N \leq 10^{12}$ は大きく感じるが、$a,b,c$に当てはまるような素数はつまり$10^6$以下で、そのような数が素数か判定するには$10^3$までの素数だけが必要なので、問題の大きさは見た目より小さい。

- 素数$a$を小さい方から順に試し、個数の総和をとる
  - 素数$b > a$を順に試し、個数の総和をとる
    - 素数$c> b$を順に試し、
      - $a^2 \cdot b \cdot c^2 \leq N$ となる $c$ の個数を数える

最後のところで、一つずつ試すのは無駄なので、$c^2 \leq N / a^2 / b$ を満たす $c$ の個数を一度に数えるには、$a, b$ の最小値が $2,3$ なので、$c^2 \leq N / 12$ までの素数を番号付きで記録しておき、
数える代わりに、この条件を満たす最大の$c = p_k$、そのときの$b=p_j$のとき、$c$になれる素数の個数は$k - j$と求められる。

$b$を試す範囲は、$k - j \geq 0$となるところ。

$a$を試す範囲は、$a = p_i, b = p_{i+1}, c = p_{i+2}$ と最小の選択をしたときに $a^2 \cdot b \cdot c^2 \leq N$ となる範囲。

## 結果

```haskell
import qualified Data.IntMap as IM
import Data.Maybe
import Data.List

abc300d :: Int -> Int
abc300d n = sum
  [ sum $ takeWhile (0 <) $ map (countC a) bjs
  | (a,_):bjs <- takeWhile acond $ tails $ zip primes [1..]
  ]
  where
    n12 = div n 12
-- (使う範囲の)素数の番号を引けるIntMap
    pm = IM.fromAscList $ zip (takeWhile ((n12 >=) . (^ 2)) primes) [1..]

-- aの探索範囲か判定
    acond ((a,_):(b,_):(c,_):_) = a * a * b * c * c <= n

-- a, b (=pj) に対する c の個数
    countC a (b, j) =
        maybe 0 (max 0 . subtract j . snd) $
        IM.lookupLE cmax pm
      where
        cmax = floor $ sqrt $ fromIntegral n / fromIntegral (a * a * b) -- ここはsqrtで妥協

primes :: [Int]
primes = 2 : 3 : [x | w <- [5,11..], x <- [w, w+2], isPrime x]

isPrime :: Int -> Bool
isPrime x = all ((0 /=) . (mod x)) $ takeWhile ((x >=) . (^ 2)) primes
```

リスト内包表記は、生成器が作った候補を採用するか却下するかはガードで選択できるが、生成器の生成を外から終了させるような機構がないので、このように、生成器側に `takeWhile` で停止条件を盛り込む、あまりスマートでないやり方でしのいでいる。命令型のループなら強制脱出してしまえば済むのに、もう少し何とかならないかと思う。

# E - Dice Product 3

[問題 ABC300E](https://atcoder.jp/contests/abc300/tasks/abc300_e)

シグネチャを決める。

```haskell
abc300e :: Int  -- N
        -> Int  -- 答え
```

- $\times 1$ では、数は変化しない。
- $\times 2$ では、素因数2が1つ増える。
- $\times 3$ では、素因数3が1つ増える。
- $\times 4$ では、素因数2が2つ増える。
- $\times 5$ では、素因数5が1つ増える。
- $\times 6$ では、素因数2と3が1ずつ増える。

1から始めて、これらの操作で$N$に到達するには、$N$がもともと、素因数として$2,3,5$のみを持つものである必要がある。そうでないときはどうやっても到達できない。
$N = 2^p \cdot 3^q \cdot 5^r$ とする。
3次元の格子状のマスを考え、初期位置 $(0,0,0)$ に到達する確率が 1、サイコロによる遷移を考え、$N$の位置$(p,q,r)$ に到達する確率を求めたい。

あるマス$(x,y,z)$にいるときに、サイコロを振って、1が出たら移動しない、2が出たら$(x+1,y,z)$、3が出たら$(x,y+1,z)$、4が出たら$(x+2,y,z)$、5が出たら$(x,y,z+1)$、6が出たら$(x+1,y+1,z)$に移動する。これらの確率は均等に1/6だが、1が出て足踏みをした場合も、最終的にはそれ以外の目を出して他に移動する確率が均等なので、結局1/5の確率で他に移動するとみなしてよい。

上の「進む」で考えると配るDPになるが、あるマスに直接侵入する経路はそれらを逆にしたものになり、集めるDPでも素直に考えればよい。

## 結果

```haskell
import Data.Array
import Data.List

abc300e :: Int -> Int
abc300e n
  | s /= 1    = 0                -- 2^p*3^q*5^r の形でないとき
  | otherwise = arr ! (p,q,r)
  where
    p:q:r:s:_ = pfloop n 0 [2,3,5]
    bnds = ((0,0,0),(p,q,r))
    arr = listArray bnds $ map f $ range bnds
    neighbors x y z = sum $
      [arr ! (pred x,y,z) | x > 0] ++ -- 2
      [arr ! (x,pred y,z) | y > 0] ++ -- 3
      [arr ! (x-2   ,y,z) | x > 1] ++ -- 4
      [arr ! (x,y,pred z) | z > 0] ++ -- 5
      [arr ! (pred x,pred y,z) | x > 0, y > 0] -- 6
    f (0,0,0) = 1
    f (x,y,z) = mul recip5 $ neighbors x y z
    recip5 = modRecip 5

-- 2,3,5だけで割り尽くしてp,q,rを求め、残った値sと共に[p,q,r,s]にして返す
pfloop n 0 [] = [n]
pfloop n c dds@(d:ds) =
  case divMod n d of
    (q,0) -> pfloop q (succ c) dds
    _     -> c : pfloop n 0 ds

modBase = 998244353
reg x = mod x modBase
mul x y = reg $ x * y

-- モジュロ逆数
modRecip a = powerish mul 1 a (modBase - 2)

powerish mul i a b = foldl' mul i [p | (True, p) <- zip bs ps]
  where
    bs = map odd $ takeWhile (0 <) $ iterate (flip div 2) b
    ps = iterate (\x -> mul x x) a
```