はじめに

この記事のmemoizeを使用します。

2-3 動的計画法

純粋関数型言語としては、扱いにくいところですね。

探索のメモ化と動的計画法

01 ナップサック問題

愚直

どうせ遅いので、リストの添え字アクセスもそのままにしています。

solve n goods w = f 0 w where
  f i j
    | i == n = 0
    | j < wi = f (i+1) j
    | otherwise = max (f (i+1) j) (f (i+1) (j-wi) + vi)
    where (wi, vi) = goods !! i

メモ化再帰

これがめんどくさくてmemoizeを作りました。memoizeにしか使っていないところは隠しておきます。

import Control.Monad
import qualified Data.Vector.Unboxed as U

solve :: Int -> [(Int,Int)] -> Int -> Int
solve n goods' w = f (0, w) where
  goods = U.fromList goods'
  f = memoize ((0,0), (n,w)) [(0,w)] f'
  f' f (i, j)
    | i == n = return 0
    | j < wi = nxt
    | otherwise = liftM2 max nxt nx'
    where
      nxt = f (i+1, j)
      nx' = (+vi) <$> f (i+1, j-wi)
      (wi, vi) = goods U.! i

ボトムアップ

foldlでもDPができます。

import Control.Monad
import qualified Data.Vector.Unboxed as U

solve n goods w = U.last $ foldl f initial goods where
  f acc (w, v) = U.zipWith max acc pick where
    pick = U.map (v+) $ U.replicate w (-v) U.++ acc
  initial = U.replicate (w+1) (0::Int)

最長共通部分列問題

カリー化されていない引数を持つのは慣れないですね。

import Control.Monad
import Data.Vector.Unboxed ((!))
import qualified Data.Vector.Unboxed as U

solve :: Int -> Int -> String -> String -> Int
solve n m s' t' = f (n-1, m-1) where
  f = memoize ((-1,-1), (n-1, m-1)) f'
  f' _ (-1, _) = return 0
  f' _ (_, -1) = return 0
  f' f (i, j)
    | s!i == t!j = succ <$> f (i-1, j-1)
    | otherwise = liftM2 max (f (i-1, j)) (f (i, j-1))
  [s, t] = map U.fromList [s', t']

漸化式を工夫する

個数制限なしナップサック問題

memoize、けっこう便利です。

import Control.Monad
import qualified Data.Vector.Unboxed as U

solve :: Int -> [(Int, Int)] -> Int -> Int
solve n goods w = f (n, w) where
  f = memoize ((0,0), (n,w)) f'
  f' f (i, j)
    | i == 0 = return 0
    | j < wi = pre
    | otherwise = liftM2 max pre pr'
    where
      pre = f (i-1, j)
      pr' = (+vi) <$> f (i, j-wi)
      (wi, vi) = U.fromList goods U.! (i-1)

配列再利用とか添え字を交互に使うとかはfoldlの出番ですね。01ナップサック問題のボトムアップで書いたのと同じ。

01ナップサック問題その2

Data.Functor.<&>を使ってみました。ちょっと見やすいかも。

import Control.Monad
import Data.Functor
import qualified Data.Vector.Unboxed as U

solve :: Int -> [(Int,Int)] -> Int -> Int
solve n goods w = ans where
  ans = maximum [v | v <- [0..mv*n], f (n, v) <= w]
  mv = maximum $ map snd goods
  f = memoize ((0, 0), (n, mv*n)) f'
  f' f (i, j)
    | i == 0 = return $ if j == 0 then 0 else w+1
    | j < vi = pre
    | otherwise = liftM2 min pre pr'
    where
      pre = f (i-1, j)
      pr' = f (i-1, j-vi) <&> (+wi)
      (wi, vi) = U.fromList goods U.! (i-1)

個数制限付き部分和問題

import Control.Monad
import qualified Data.Vector.Unboxed as U

solve :: Int -> [(Int, Int)] -> Int -> Bool
solve n am k = f (n, k) >= 0 where
  f = memoize ((0, 0), (n, k)) f'
  f' _ (0, j) = return $ -j
  f' f (i, j) = do
    a <- f (i-1, j)
    if a >= 0 then return mi
    else if j < ai then return $ -1
    else pred <$> f (i, j-ai)
    where (ai, mi) = U.fromList am U.! (i-1)

最長増加部分列問題

Data.Vector.Algorithms.Search.binarySearchL の説明がわかりやすかったです。

Finds the lowest index in a given sorted vector at which the given element could be inserted while maintaining the sortedness.

sortedness を保った状態で挿入できる最小のインデックスを求める、という感覚はなかったかも。

import Control.Monad
import Control.Monad.ST
import qualified Data.Vector.Unboxed.Mutable as UM
import Data.Vector.Algorithms.Search

solve n a = runST $ do
  dp <- UM.replicate n (10^6+1)
  forM_ a $ \a -> do
    i <- binarySearchL dp a
    UM.write dp i a
  binarySearchL dp (10^6+1)

計算問題に対するDP

分割数

import Control.Monad

solve :: Int -> Int -> Int -> Int
solve n m mo = f (n, m) where
  f = memoize ((0, 0), (n, m)) f'
  f' f (i, j)
    | i == 0 = return $ if j == 0 then 1 else 0
    | i > j = f (i-1, j)
    | otherwise =
      (`mod` m) <$> liftM2 (+) (f (i, j-i)) (f (i-1, j))

重複組み合わせ

liftM3までするぐらいならdo構文を使ってもよさそうですね。

import Control.Monad
import qualified Data.Vector.Unboxed as U

solve :: Int -> Int -> [Int] -> Int -> Int
solve n m a mo = f (n, m) where
  f = memoize ((0, 0), (n, m)) f'
  f' f (i, j)
    | j == 0 = return 1
    | i == 0 = return 0
    | j-1-ai < 0 = (`mod` mo) <$> liftM2 (+) p q
    | otherwise = (`mod` mo) <$> liftM3 (+-) p q r
    where
      p = f (i, j-1)
      q = f (i-1, j)
      r = f (i-1, j-1-ai)
      ai = U.fromList a U.! (i-1)
      (+-) a b c = a + b - c

おわり

めんどくせーと思って抽象化したmemoizeがとてもよく働きましたね。関数を含んだ抽象化がやりやすいのは関数型言語の強味だと思います。ところでそろそろ本に載っているサンプル１つでチェックするのはどうなの、という感じがしてきました。まあいいや。

cunitac 競技プログラミング

Haskellで蟻本 2-3