Haskellで動的計画法(最長共通部分列問題)

蟻本の「最長共通部分列問題」(56p)をHaskellで実装してみた。

Haskellでの動的計画法(DP)の実装方法が全然わからなかったので、以下のリンクを参考にした - Haskellで蟻本やるぜ5(DP)

{-# LANGUAGE BangPatterns, FlexibleContexts #-}

import Control.Monad
import Control.Monad.ST
import Data.Array
import Data.Array.ST
import Data.Time
import Debug.Trace

-- 最長共通部分列問題

-- 再帰(Data.Array)
solver :: Int -> Int -> [String] -> [String] -> Int
solver n m ss ts = rec n m
  where
    memo = listArray ((0, 0), (n, m)) [rec i j | i <- [n..0], j <- [m..0]]
    --
    rec 0 _ = 0
    rec _ 0 = 0
    rec i j =
      if si == tj
        then 1 + rec (pred i) (pred j)
        else max (rec (pred i) j) (rec i (pred j))
      where
        si = ss !! (pred i)
        tj = ts !! (pred j)


-- STモナド
solver' :: Int -> Int -> [String] -> [String] -> Int
solver' n m ss ts = runST $ do
  dp <- newArray ((0, 0), (n, m)) 0 :: ST s (STUArray s (Int, Int) Int)
  forM_ [0..(pred n)] $ \i -> do
    let si = ss !! i
    forM_ [0..(pred m)] $ \j -> do
      let tj = ts !! j
      if si == tj
        then do
          x <- readArray dp (i, j)
          writeArray dp (succ i, succ j) (x + 1)
        else do
          x1 <- readArray dp (i, succ j)
          x2 <- readArray dp (succ i, j)
          writeArray dp (succ i, succ j) (max x1 x2)
  readArray dp (n, m)

-- STモナド&再帰
solver'' :: Int -> Int -> [String] -> [String] -> Int
solver'' n m ss ts = runST $ do
    dp <- newArray ((0, 0), (n, m)) 0 :: ST s (STUArray s (Int, Int) Int)
    memo <- newArray ((0, 0), (n, m)) False :: ST s (STUArray s (Int, Int) Bool)
    -- (0, _), (_, 0)のときは0なので計算済みにしておく
    sequence [writeArray memo (0, i) True | i <- [0..m]]
    sequence [writeArray memo (i, 0) True | i <- [0..m]]
    rec dp memo (n, m)
  where
    rec dp memo (i, j) = do
      exists <- readArray memo (i, j)
      when (not exists) $ do
        let si = ss !! (pred i)
            tj = ts !! (pred j)
        if si == tj
          then do
            x <- rec dp memo (pred i, pred j)
            writeArray dp (i, j) (x + 1)
          else do
            x1 <- rec dp memo (pred i, j)
            x2 <- rec dp memo (i, pred j)
            writeArray dp (i, j) (max x1 x2)
        writeArray memo (i, j) True
      readArray dp (i, j)


main = do
    -- answer : 3
    let n = 4
        m = 4
        s = "abcd"
        t = "becd"
    print $ solver n m (map (:[]) s) (map (:[]) t)
    print $ solver' n m (map (:[]) s) (map (:[]) t)
    print $ solver'' n m (map (:[]) s) (map (:[]) t)

実装した感じだと、2番目の「STモナド」利用が、元のソースと同じような感覚で書けた。
C++から移植する際は2番目の書き方ベースで進めると良いかもしれない。