HaskellでDP（Dynamorphism）やるぜ
dynamorphism
前回、前々回とDP（動的計画法）をやってきた。
前に一緒に働いていた に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版は、速いしメモリ使用量も少ない。
なぜだろう。。
Author And Source
この問題について(HaskellでDP（Dynamorphism）やるぜ), 我々は、より多くの情報をここで見つけました https://zenn.dev/forest1040/articles/f0e48d0d0704c6b6c781著者帰属：元の著者の情報は、元のURLに含まれています。著作権は原作者に属する。
Collection and Share based on the CC protocol