HaskellでDP（Dynamorphism）やるぜ

dynamorphism

前回、前々回とDP（動的計画法）をやってきた。
前に一緒に働いていた@cutsea110にdynamorphismというものを教えてもらった。
本物のHaskerは、dynamorphismでDPをやるんだなと思い、勉強してみるぜ。

取り敢えず、Dynamorphism 〜 Haskellでも動的計画法がしたい！ 〜を読んでみた。
数学っぽい定義と可換図式をチラ見したときは、なにこれ怖いと思ったけれど、すごくわかりやすかったぜ。
「5. histomorphism」のあたりで気を失っていたから、ところどころ記憶がないが。。

dynamorphismとは

取り敢えず、dynamorphismというのは、anamorphism + histomorphism のことで、 anamorphismがデータ構造の構築を行う。（DPの漸化式の元データを作る感じだろう。）
histomorphism は、histmorphism は、catamorphism の拡張。

• catamorphism が、データ構造を畳み込んで1つの値にする処理（foldの一般化）らしい。
• histomorphism は、catamorphism の過去の履歴を参照できるように拡張したもの。

結局、anamorphism + catamorphism(histomorphism) で、再帰処理が実行でき、dynamorphismは、catamorphismの箇所にhistomorphismを使うことによるメモ化で、処理速度を向上したものらしい。

dynamorphism（dyna）やanamorphism(ana)等の定義はライブラリ化できるので、
実装としては、以下の２つの関数を実装して、dynaに渡せばよい。

• psi: anaで使うデータ構造を構築する処理
• phi: histで使うデータを畳み込みする処理

畳み込み処理で履歴データを参照し、処理の最適化を行う。

サンプルコード

Dynamorphism 〜 Haskellでも動的計画法がしたい！ 〜のサンプルは、こんな感じで実行できる。

{- 関手 f について不動点を取る
  ここで、 inF  :: f (FixF f) -> FixF f
                 outF :: FixF f     -> f (FixF f)
  であり、inF . outF = id, outF . inF = id
  よって同型の定義より f について不動点を取れている。-}
newtype FixF f = InF { outF :: f (FixF f) }

-- Fx = A × F(X)
data Fx f a x = FCons a (f x)
instance Functor f => Functor (Fx f a) where
  fmap f (FCons x xs) = FCons x (fmap f xs)

-- Cofree の宣言
newtype Cofree f a = Cf { unCf :: FixF (Fx f a) }

-- Cofree が関手に成るための宣言
instance Functor f => Functor (Cofree f) where
  fmap f = Cf . ana (phi . outF) . unCf where
    phi (FCons a b) = FCons (f a) b

-- ノードの付加情報を取り出す
extract :: Functor f => Cofree f a -> a
extract cf = case (outF $ unCf cf) of
  FCons a _ -> a

-- ノードを取り出す
sub :: Functor f => Cofree f a -> f (Cofree f a)
sub cf = case (outF $ unCf cf) of
  FCons _ b -> fmap Cf b

cata :: Functor f => (f a -> a) -> FixF f -> a
cata phi = phi . fmap (cata phi) . outF

ana :: Functor f => (a -> f a) -> a -> FixF f
ana psi = InF . fmap (ana psi) . psi

hylo :: Functor f => (f x -> x) -> (y -> f y) -> (y -> x)
hylo phi psi = cata phi . ana psi

dyna :: Functor f => (f (Cofree f x) -> x) -> (y -> f y) -> (y -> x)
dyna phi psi = extract . hylo ap psi where
  ap a = Cf $ InF $ FCons (phi a) (fmap unCf a)


-- psi によって作られる中間データ構造、(Int, Int) のフィールドを持ち、dp[i][j] のインデックス i,j を表現している。
data KSTree a = KSTree (Int, Int) (Maybe a)
instance Functor KSTree where
  fmap f (KSTree a Nothing)  = KSTree a Nothing
  fmap f (KSTree a (Just b)) = KSTree a (Just (f b))

{- 0-1ナップザック問題を解く。c は全重量の制約、vは品物の価値のリスト、wは重量のリスト -}
knapsack :: Int -> [Int] -> [Int] -> Int
knapsack c v w = dyna phi psi $ (n,c) where
  n = length w -- 品物の数

  psi (0,0) = KSTree (n,0) Nothing
  psi (0,j) = KSTree (n,j) (Just (n, j-1))
  psi (i,j) = KSTree (n-i,j) (Just (i-1, j))

  phi (KSTree _ Nothing) = 0
  phi (KSTree (i,j) (Just cs))
    | i == n      = 0
    | w !! i <= j = max x1 x2
    | otherwise   = x1
    where
      x1 = back 1 cs
      x2 = (v !! i) + (back (1 + (n + 1) * (w !! i)) cs)

  {- 過去の結果を遡って参照するための関数 -}
  back 1 cs = extract cs
  back i cs = case sub cs of
    (KSTree _ (Just b)) -> back (i - 1) b

main :: IO ()
main = do
  print $ knapsack 5 [4,2,5,8] [2,2,1,3] -- 13

Atcoderへの提出

これを改造して、Atcoderに提出してみた。
結果は、無念のTLE。。

import Data.Array
import qualified Data.ByteString.Char8 as BS
import qualified Data.List as DL
import qualified Data.Char as DC
import qualified Control.Monad as CM

{- 関手 f について不動点を取る
  ここで、 inF  :: f (FixF f) -> FixF f
                 outF :: FixF f     -> f (FixF f)
  であり、inF . outF = id, outF . inF = id
  よって同型の定義より f について不動点を取れている。-}
newtype FixF f = InF { outF :: f (FixF f) }

-- Fx = A × F(X)
data Fx f a x = FCons a (f x)
instance Functor f => Functor (Fx f a) where
  fmap f (FCons x xs) = FCons x (fmap f xs)

-- Cofree の宣言
newtype Cofree f a = Cf { unCf :: FixF (Fx f a) }

-- Cofree が関手に成るための宣言
instance Functor f => Functor (Cofree f) where
  fmap f = Cf . ana (phi . outF) . unCf where
    phi (FCons a b) = FCons (f a) b

-- ノードの付加情報を取り出す
extract :: Functor f => Cofree f a -> a
extract cf = case (outF $ unCf cf) of
  FCons a _ -> a

-- ノードを取り出す
sub :: Functor f => Cofree f a -> f (Cofree f a)
sub cf = case (outF $ unCf cf) of
  FCons _ b -> fmap Cf b

cata :: Functor f => (f a -> a) -> FixF f -> a
cata phi = phi . fmap (cata phi) . outF

ana :: Functor f => (a -> f a) -> a -> FixF f
ana psi = InF . fmap (ana psi) . psi

hylo :: Functor f => (f x -> x) -> (y -> f y) -> (y -> x)
hylo phi psi = cata phi . ana psi

dyna :: Functor f => (f (Cofree f x) -> x) -> (y -> f y) -> (y -> x)
dyna phi psi = extract . hylo ap psi where
  ap a = Cf $ InF $ FCons (phi a) (fmap unCf a)


-- psi によって作られる中間データ構造、(Int, Int) のフィールドを持ち、dp[i][j] のインデックス i,j を表現している。
data KSTree a = KSTree (Int, Int) (Maybe a)
instance Functor KSTree where
  fmap f (KSTree a Nothing)  = KSTree a Nothing
  fmap f (KSTree a (Just b)) = KSTree a (Just (f b))

knapsack :: Int -> Int -> [(Int,Int)] -> Int
knapsack n c wvs = dyna phi psi $ (n,c) where
  wva = listArray (0, n-1) wvs

  psi (0,0) = KSTree (n,0) Nothing
  psi (0,j) = KSTree (n,j) (Just (n, j-1))
  psi (i,j) = KSTree (n-i,j) (Just (i-1, j))

  phi (KSTree _ Nothing) = 0
  phi (KSTree (i,j) (Just cs))
    | i == n      = 0
    | w <= j = max x1 x2
    | otherwise   = x1
    where
      (w, v) = wva ! i
      x1 = back 1 cs
      x2 = v + (back (1 + (n + 1) * w) cs)

  {- 過去の結果を遡って参照するための関数 -}
  back 1 cs = extract cs
  back i cs = case sub cs of
    (KSTree _ (Just b)) -> back (i - 1) b

getIntList = DL.unfoldr (BS.readInt .  BS.dropWhile DC.isSpace) <$> BS.getLine

main :: IO ()
main = do
  [n,maxW] <- getIntList
  items <- CM.replicateM n $ do
    [w,v] <- getIntList
    return (w,v)
  print $ knapsack n maxW items

Atcoderに出すにあたっての、サンプルコードの変更点

• knapsackのパラメータを前回の関数と同じようにタプル化している。
• ByteString対応

cutsea110版との比較

cutsea110版は、速いしメモリ使用量も少ない。
なぜだろう。。