📚

Haskellで蟻本やるぜ5(DP)

7 min read

前回の続き。
もはやLVS7K'S BLOGの写経になりつつあるが。
今回からDP(動的計画法)をやるぜ。
サンプルデータは、ここから借用したぜ。

2-3 ナップサック問題

毎度、ここをほぼパクリにしたお。

-- https://lvs7k.github.io/posts/2018/11/pccb-easy-3/
-- https://download-takeshi.hatenablog.com/entry/20100301/1267476665
{-# LANGUAGE BangPatterns, FlexibleContexts #-}

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

-- 01 ナップサック問題
q1 :: Int -> Int -> [(Int, Int)] -> Int
q1 n m wvs = go n m
  where
    wva = listArray (1, n) wvs
    -- 蟻本のiを増やしていくパターン
    memo = listArray ((0, 0), (n, m)) [go i j | i <- [0 .. n], j <- [0 .. m]]
    go 0 _ = 0
    go i j
        | j < w     = x1        -- 荷物が入らない
        | otherwise = max x1 x2 -- 入れる場合と入れない場合の両方を試す
      where
        (w, v) = wva ! i
        -- 荷物を入れる場合
        x1 = memo ! (i - 1, j)
        -- 荷物を入れない場合
        x2 = memo ! (i - 1, j - w) + v

q1' :: Int -> Int -> [(Int, Int)] -> Int
q1' n m wvs = runST $ do
    dp <- newArray ((0, 0), (n, m)) 0 :: ST s (STUArray s (Int, Int) Int)
    forM_ [1 .. n] $ \i -> do
        -- 荷物データから重さと価値を取得
        let (w, v) = wva ! i
        -- dp
        forM_ [0 .. m] $ \j -> do
            x1 <- readArray dp (i - 1, j)
            if j < w then
                writeArray dp (i, j) x1
            else do
                x2 <- readArray dp (i - 1, j - w)
                writeArray dp (i, j) (max x1 (x2 + v))
    readArray dp (n, m)
  where
    -- 荷物データ
    wva = listArray (1, n) wvs

q1'' :: Int -> Int -> [(Int, Int)] -> Int
q1'' n m wvs = 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)
    -- sequence_ は、(モナドの)リストを取り、要素を順に実行して、値は返さない関数
    -- memoがn=0のときは、0を返させるよう初期化(True:計算済みにしておく)
    sequence_ [writeArray memo (0, i) True | i <- [0 .. m]]
    go dp memo (n, m)
  where
    wva = listArray (1, n) wvs
    go dp memo (i, j) = do
        exists <- readArray memo (i, j)
        -- まだ計算していない場合
        when (not exists) $ do
            let (w, v) = wva ! i
            x1 <- go dp memo (i - 1, j)
            if j < w
                then do
                    writeArray dp (i, j) x1
                else do
                    x2 <- go dp memo (i - 1, j - w)
                    writeArray dp (i, j) (max x1 (x2 + v))
            writeArray memo (i, j) True
        readArray dp (i, j)


main :: IO ()
main = do
    x <- getCurrentTime
    -- let ret = q1 4 5 [(2,3),(1,2),(3,4),(2,2)]
    let ret = q1 10 300 [(168,496),(10,45),(145,325),(60,347),(10,61),(124,486),(124,446),(105,22),(126,110),(184,475)]
    print ret
    y <- getCurrentTime
    print $ diffUTCTime y x
    x' <- getCurrentTime
    --let ret' = q1' 4 5 [(2,3),(1,2),(3,4),(2,2)]
    let ret' = q1' 10 300 [(168,496),(10,45),(145,325),(60,347),(10,61),(124,486),(124,446),(105,22),(126,110),(184,475)]
    print ret'
    y' <- getCurrentTime
    print $ diffUTCTime y' x'
    x'' <- getCurrentTime
    --let ret'' = q1'' 4 5 [(2,3),(1,2),(3,4),(2,2)]
    let ret'' = q1'' 10 300 [(168,496),(10,45),(145,325),(60,347),(10,61),(124,486),(124,446),(105,22),(126,110),(184,475)]
    print ret''
    y'' <- getCurrentTime
    print $ diffUTCTime y'' x''
    x <- getCurrentTime
    -- let ret = q1 4 5 [(2,3),(1,2),(3,4),(2,2)]
    let ret = q1 10 300 [(168,496),(10,45),(145,325),(60,347),(10,61),(124,486),(124,446),(105,22),(126,110),(184,475)]
    print ret
    y <- getCurrentTime
    print $ diffUTCTime y x

q1 が純粋にHaskellでメモ化しながら説いている
q1' はDPを使っている
q1''はDPとメモ化の両方を使っている

mainで時間測定しつつ、q1とq1'とq1''を実行している。
メモリキャッシュの関係か、2回目の実行が早いので、q1は2回実行している。
q1よりもDPを使っているq1'の方が速いぜ!と思っていたら違った。

$ ./sample
1038
0.000669s
1038
0.002878s
1038
0.000464s
1038
0.0002s

ということで、プロファイルを取ってみる。
それぞれの関数を別ファイルにして、実行してみた。

q1 純情メモ

$ stack ghc sample1.hs
$ ./sample1 +RTS -s
1038
0.000748s
         860,480 bytes allocated in the heap
           3,480 bytes copied during GC
          44,576 bytes maximum residency (1 sample(s))
          25,056 bytes maximum slop
               0 MB total memory in use (0 MB lost due to fragmentation)

                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0         0 colls,     0 par    0.000s   0.000s     0.0000s    0.0000s
  Gen  1         1 colls,     0 par    0.000s   0.000s     0.0002s    0.0002s

  INIT    time    0.000s  (  0.003s elapsed)
  MUT     time    0.000s  (  0.001s elapsed)
  GC      time    0.000s  (  0.000s elapsed)
  EXIT    time    0.000s  (  0.011s elapsed)
  Total   time    0.001s  (  0.015s elapsed)

  %GC     time       0.0%  (0.0% elapsed)

  Alloc rate    1,964,566,210 bytes per MUT second

  Productivity  51.6% of total user, 6.1% of total elapsed

まぁ、こんなもんでしょ

DP

$ stack ghc sample2.hs
$ ./sample2 +RTS -s
1038
0.003429s
       7,447,424 bytes allocated in the heap
          21,008 bytes copied during GC
          56,640 bytes maximum residency (2 sample(s))
          29,152 bytes maximum slop
               0 MB total memory in use (0 MB lost due to fragmentation)

                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0         6 colls,     0 par    0.000s   0.000s     0.0000s    0.0000s
  Gen  1         2 colls,     0 par    0.000s   0.000s     0.0001s    0.0002s

  INIT    time    0.000s  (  0.002s elapsed)
  MUT     time    0.003s  (  0.003s elapsed)
  GC      time    0.000s  (  0.000s elapsed)
  EXIT    time    0.000s  (  0.008s elapsed)
  Total   time    0.003s  (  0.014s elapsed)

  %GC     time       0.0%  (0.0% elapsed)

  Alloc rate    2,763,422,634 bytes per MUT second

  Productivity  82.6% of total user, 24.0% of total elapsed

heapメモリを7.4MBも使っているお。

DP+メモ化

$ stack ghc sample3.hs
$ ./sample3 +RTS -s
1038
0.001582s
       1,263,504 bytes allocated in the heap
          10,200 bytes copied during GC
          44,576 bytes maximum residency (1 sample(s))
          29,152 bytes maximum slop
               0 MB total memory in use (0 MB lost due to fragmentation)

                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0         1 colls,     0 par    0.000s   0.000s     0.0000s    0.0000s
  Gen  1         1 colls,     0 par    0.000s   0.000s     0.0002s    0.0002s

  INIT    time    0.000s  (  0.003s elapsed)
  MUT     time    0.001s  (  0.002s elapsed)
  GC      time    0.000s  (  0.000s elapsed)
  EXIT    time    0.000s  (  0.009s elapsed)
  Total   time    0.001s  (  0.014s elapsed)

  %GC     time       0.0%  (0.0% elapsed)

  Alloc rate    1,294,573,770 bytes per MUT second

  Productivity  68.4% of total user, 12.0% of total elapsed

メモリ使用量は、1.2MBでましになった。

メモ化だけで、DPに勝てるのはうれしい。
Haskellで、単純にDPにするとArray使うから手続き型で書いているのと変わらん。
しかし、おかしいなぁ。
データが少ないからかなぁ。
続きを書いたぜ。
大量データの場合は、結果が変わったぜ。

Discussion

ログインするとコメントできます