Arantium Maestum

プログラミング、囲碁、読書の話題

`foldr`で`dropWhile`と不動点コンビネータ

Haskell

前回のブログの問題元は今は亡き？Monad.Reader第6号の"Getting a Fix from the Right Fold"という記事。

私が考えた答えの「失敗例」は出てくるけど、パターンマッチを使わないで遅延評価が無限リストにも効く解は出てこない。

しかし別解は非常にエレガントなものが一つ、理解の範疇になかったものが一つ。

foldrで関数を作成する

エレガントな解は「foldrと入力リストでまず関数を作り、その関数を再度リストに適用する」というもの。

まずは簡単な定義から：

dropWhile p xs = foldr f id xs xs
  where f x g
          | p x = g . tail
          | otherwise = id

どういうふうに作動するかといえば

dropWhile (<3) [1..10]
= foldr f id [1..10] [1..10]
= f 1 (foldr f id [2..10]) [1..10]
= (foldr f id [2..10] . tail) [1..10]
= (f 2 (foldr f id [3..10]) . tail) [1..10]
= (foldr f id [3..10] . tail . tail) [1..10]
= (f 3 (foldr f id [4..10]) . tail . tail) [1..10]
= (id . tail . tail) [1..10]
= (id . tail) [2..10]
= id [3..10]
= [3..10]

正常に作動するし無限リストも扱えそう。ただし、遅延評価している分(id . tail .... tail)の部分が一旦スペースリークを起こしているのがわかる。

foldr f id xs xsのfの定義を同値性を保ったまま少しいじることで効率化が図れる：

dropWhile p xs = foldr f id xs xs
  where f x g ys@(_:zs)
          | p x = g . zs
          | otherwise = ys

where f x gだったところをf x g ysに変え、さらにys@(_:zs)とtail部分にパターンマッチしている。

これで挙動は以下のとおりとなる：

dropWhile (<3) [1..10]
= foldr f id [1..10] [1..10]
= f 1 (foldr f id [2..10]) [1..10]
= foldr f id [2..10] [2..10]
= f 2 (foldr f id [3..10]) [2..10]
= foldr f id [3..10] [3..10]
= f 3 (foldr f id [4..10]) [3..10]
= [3..10]

tailを貯めてから最終的に適用するのではなく、都度都度最終的な引数であるリストに対してtailを適用するのと同値なパターンマッチをすることで、効率よく「foldrとリストで関数を作って、同じリストに適用する」を実装している。

foldrで不動点コンビネータを作成

さて、不動点コンビネータというものがある。

fix f = f (fix f)

という性質を持つ関数fixのことだ。

foldrでfixを定義できる：

fix :: (a -> b) -> a -> b
fix f = foldr (const f) undefined (repeat undefined)

使われている関数をいくつか説明する。

constは二つの引数をとり、第二引数を評価することなく必ず第一引数を返す：

const :: a -> b -> a
const f _ = f

repeat xはxが無限に続くリストを返す：

repeat :: a -> [a]
repeat x = x : repeat x

fix f = f (fix f)が成り立つ証明：

fix f
= foldr (const f) undefined (repeat undefined)
= foldr (const f) undefined (undefined : repeat undefined)
= (const f) undefined (foldr (const f) undefined (repeat undefined))
= f (foldr (const f) undefined (repeat undefined)
= f (fixed f) -- QED

undefinedが任意の型を取り得ることを利用している。

こうして定義した不動点コンビネータを使って任意の再帰を表現できる、らしい。

たしかにTypes and Programming Languagesでも

The omega combinator has a useful generalization called the fixed-point combinator, which can be used to help define recursive functions such as factorial

などと書いてあった。

sumで試してみる。

sumの再帰的定義：

sum :: Num a => [a] -> a
sum [] = 0
sum (x:xs) = x + sum xs

この定義から再帰部分を抜き出して引数rとする：

sumNoRec r [] = 0
sumNoRec r (x:xs) = x + r xs

このsumNoRecをfixに引数として渡すと、再帰的sumと同じ関数になる：

sumfp = fix sumNoRec

確かめてみる：

sumfp [1, 2, 3]
= (fix sumNoRec) [1, 2, 3]
= (foldr (const sumNoRec) undefined (repeat undefined)) [1, 2, 3]
= (foldr (const sumNoRec) undefined (undefined : repeat undefined)) [1, 2, 3]
= (const sumNoRec) undefined (foldr (const sumNoRec) undefined (repeat undefined)) [1, 2, 3]
= sumNoRec (foldr (const sumNoRec) undefined (repeat undefined)) [1, 2, 3]
= 1 + (foldr (const sumNoRec) undefined (repeat undefined)) [2, 3]
= 1 + (foldr (const sumNoRec) undefined (undefined : repeat undefined)) [2, 3]
= 1 + (const sumNoRec) undefined (foldr (const sumNoRec) undefined (repeat undefined)) [2, 3]
= 1 + sumNoRec (foldr (const sumNoRec) undefined (repeat undefined)) [2, 3]
= 1 + (2 + (foldr (const sumNoRec) undefined (repeat undefined)) [3])
= 1 + (2 + (foldr (const sumNoRec) undefined (undefined : repeat undefined)) [3])
= 1 + (2 + (const sumNoRec) undefined (foldr (const sumNoRec) undefined (repeat undefined)) [3])
= 1 + (2 + sumNoRec (foldr (const sumNoRec) undefined (repeat undefined)) [3])
= 1 + (2 + (3 + (foldr (const sumNoRec) undefined (repeat undefined)) []))
= 1 + (2 + (3 + (foldr (const sumNoRec) undefined (undefined : repeat undefined)) []))
= 1 + (2 + (3 + (const sumNoRec) undefined (foldr (const sumNoRec) undefined (repeat undefined)) []))
= 1 + (2 + (3 + sumNoRec (foldr (const sumNoRec) undefined (repeat undefined)) []))
= 1 + (2 + (3 + 0))
= 6

たしかにsumNoRecの停止条件が満たされるまで、何回でもfixによってsumNoRecが適用されるのがわかる。

dropWhileをfixで

dropWhileの再帰的定義：

dropWhile p [] = []
dropWhile p ys@(x:xs)
  | p x = dropWhile p xs
  | otherwise = ys

dropWhileNRの定義：

dropWhileNR r p [] = []
dropWhileNR r p ys@(x:xs)
  | p x = r p xs
  | otherwise = ys

dropWhileFPの定義：

dropWhileFP = fix dropWhileNR

挙動チェック：

dropWhileFP (<3) [1..10]
= (fix dropWhileNR) (<3) [1..10]
= (foldr (const dropWhileNR) undefined (repeat undefined)) (<3) [1..10]
= (foldr (const dropWhileNR) undefined (undefined : repeat undefined)) (<3) [1..10]
= ((const dropWhileNR) undefined (foldr (const dropWhileNR) undefined (repeat undefined))) (<3) [1..10]
= (dropWhileNR (foldr (const dropWhileNR) undefined (repeat undefined))) (<3) [1..10]
= (foldr (const dropWhileNR) undefined (repeat undefined)) (<3) [2..10]
= (foldr (const dropWhileNR) undefined (undefined : repeat undefined)) (<3) [2..10]
= ((const dropWhileNR) undefined (foldr (const dropWhileNR) undefined (repeat undefined))) (<3) [2..10]
= (dropWhileNR (foldr (const dropWhileNR) undefined (repeat undefined))) (<3) [2..10]
= (foldr (const dropWhileNR) undefined (repeat undefined)) (<3) [3..10]
= (foldr (const dropWhileNR) undefined (undefined : repeat undefined)) (<3) [3..10]
= ((const dropWhileNR) undefined (foldr (const dropWhileNR) undefined (repeat undefined))) (<3) [3..10]
= (dropWhileNR (foldr (const dropWhileNR) undefined (repeat undefined))) (<3) [3..10]
= [3..10]

信じがたいことに実際に上手くいくようだ。というか、書き下してみてようやく何故上手くいくのかが腑に落ちてきた・・・

実用性はわからないが、とりあえず

の二点は忘れることはないと思う。

TaPLにはこういうコンビネータによる計算がいろいろと載っていそうなので、ぜひ近いうちに読んでいきたい。