Control.Arrowでエラトステネスの篩, 階乗

エラトステネスの篩の前に, 階乗をArrowでやります. 理由はおいおい分かります.

階乗を普通に

fact n = if n == 0 then 1 else n * fact (n - 1)
main = print $ fact 10

3628800

流石にこれはいいですね. はい.

Arrowに急ぐ前に, まずfixを使って書きましょう. 色々考えましたが, fixを介してArrowに行くのが一番近道です.

fix f = f (fix f)
fact = fix fact'
fact' f n = if n == 0 then 1 else n * f (n - 1)
main = print $ fact 10

3628800

さっきのfactを, 第一引数で関数を回すようにしてやるだけですね.

階乗をArrowLoopで

さて, fixで書けたらもうお手の物です. というのも, 次の書き換えができるからです.

fix f ==> loop (\(n, g) -> (g n, f g))

これについては後述します. これを適用して,

import Control.Arrow
fact = loop (\(n, g) -> (g n, fact' g))
fact' f n = if n == 0 then 1 else n * f (n - 1)
main = print $ fact 10

となります. あとはfact'を消して

import Control.Arrow
fact = loop (\(n, g) -> (g n, \n -> if n == 0 then 1 else n * g (n - 1)))
main = print $ fact 10

できあがり！ もうArrowLoopで再帰関数を書くのは怖くありません！

エラトステネスの篩

素数と言えば, こういうのを見たことがあります.

import Data.List
primes = nubBy(((>1).).gcd)[2..]
main = print $ take 20 primes

[2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71]

これでは元も子もないですね...

次は, エラトステネスの篩のコードです.

p (x:xs) = x : p [y | y <- xs, mod y x /= 0]
primes = 2:p [3,5..]
main = print $ take 20 primes

これ, よく見ればpを再帰してますよね. 再帰呼び出し, 再帰, ... loop... ArrowLoopだ！！！ だから先に(より簡単な関数である)階乗を持ってきたわけです.

まず, (x:xs)と, リスト内包表記を消します.

p x = head x : p (filter (\y -> mod y (head x) /= 0) (tail x))
primes = 2:p [3,5..]

再帰呼び出しをfixに直します.

fix f = f (fix f)
p' f x = head x : f (filter (\y -> mod y (head x) /= 0) (tail x))
p = fix p'
primes = 2:p [3,5..]

ここで,

fix p' ==> loop (\(n, g) -> (g n, p' g))

によって書き換えます.

import Control.Arrow
p' f x = head x : f (filter (\y -> mod y (head x) /= 0) (tail x))
p = loop (\(n, g) -> (g n, p' g))
primes = 2:p [3,5..]

取り敢えずp'は放っておいて, loopの中身を書きなおしましょう.

p = loop (\(n, g) -> (g n, p' g))

g nとp' gをhoge (n, g)の形に変形します.

p = loop (\(n, g) -> (uncurry(flip($)) (n, g) , (p'.snd) (n, g)))

んでもって, (&&&)でつなげれば

p = loop (uncurry(flip($)) &&& p'.snd )

完成っと！

p'を変形しよう！

実はコイツがなかなか厄介. でもがんばるもん！

p' f x = head x : f (filter (\y -> mod y (head x) /= 0) (tail x))

headとtail, filterの中の関数を取り出します.

p' f x = h : f (filter g t)
  where
    h = head x
    t = tail x
    g y = mod y h /= 0

gを変形していきます.

    g y = (/=0) $ mod y h

    g y = (/=0) $ flip mod h y

    g y = ( (/=0) . flip mod h ) y

    g = (/=0) . flip mod h

    g = (((/=0).) . flip mod) h

ここで,

f . g x == (f .) (g x)
        == ((f .) . g) x

の関係を使いました. p'全体はこうなりました.

p' f x = h : f (filter g t)
  where
    h = head x
    t = tail x
    g = (((/=0).) . flip mod) h

もちょっと変形.

p' f x = uncurry (:) (h, xs)
  where
    h = head x
    t = tail x
    g = (((/=0).) . flip mod) h
    xs = f (filter g t)

p' f x = uncurry (:) (h, xs)
  where
    h = head x
    t = tail x
    g = ((((/=0).) . flip mod).head) x
    xs = (\(g, t) -> f (filter g t)) (g, t)

xsのなかのgとtを消します.

    xs = f $ (\(g, t) -> (filter g t)) (g, t)

    xs = (f . uncurry filter) (g, t)

xsをhoge xの形に変形します.

p' f x = uncurry (:) (h, xs)
  where
    h = head x
    t = tail x
    xs = (f . uncurry filter) (((((/=0).) . flip mod).head) x, tail x)

(&&&)で分岐しよう！

p' f x = uncurry (:) (h, xs)
  where
    h = head x
    xs = (f <<< uncurry filter <<< (((((/=0).) . flip mod).head)&&& tail)) x

p' f x = uncurry (:) hxs
  where
    h = head x
    xs = (f <<< uncurry filter <<< (((((/=0).) . flip mod).head)&&& tail)) x
    hxs = (h, xs)

んー, でもxsの中に, fが入ってるよなー... つーこってhoge (f, x)の形にします. 変数aが中にあれば, とにかくhoge (a, foo)のようにタプルに直します. これ鉄則.

p' f x = uncurry (:) hxs
  where
    h = (head.snd) (f, x)
    xs = (uncurry ($) <<< id *** (uncurry filter <<< (((((/=0).) . flip mod).head)&&& tail))) (f, x)
    hxs = (h, xs)

ようやくhとxsを(&&&)で繋げられます.

p' f x = uncurry (:) hxs
  where
    hxs =
      ((head.snd) &&&
      (uncurry ($) <<< id *** (uncurry filter <<< (((((/=0).) . flip mod).head)&&& tail)))) (f, x)

hxsを消して...

p' f x = (uncurry (:) <<<
      (head.snd) &&&
      (uncurry ($) <<< id *** (uncurry filter <<< (((((/=0).) . flip mod).head)&&& tail)))) (f, x)

カーリー化して

p' f x = curry (uncurry (:) <<<
      (head.snd) &&&
      (uncurry ($) <<< id *** (uncurry filter <<< (((((/=0).) . flip mod).head)&&& tail)))) f x

引数を消す.

p' = curry (uncurry (:) <<<
      (head.snd) &&&
      uncurry ($) <<< id *** (uncurry filter <<< ((/=0).).flip mod.head&&&tail))

以上から, 全体像は

import Control.Arrow
p' = curry(uncurry(:)<<<(head.snd)&&&(uncurry($)<<<id***(uncurry filter<<<(((((/=0).).flip mod).head)&&&tail))))
p = loop (uncurry(flip($)) &&& p'.snd )
primes = 2:p [3,5..]
main = print $ take 20 primes

p'を消して

p = loop (uncurry(flip($)) &&& (curry(uncurry(:)<<<(head.snd)&&&(uncurry($)<<<id***(uncurry filter<<<(((((/=0).).flip mod).head)&&&tail)))).snd))
primes = 2:p [3,5..]

pも消そうかな

import Control.Arrow
primes = 2:(loop$uncurry(flip($)) &&& (curry(uncurry(:)<<<(head.snd)&&&(uncurry($)<<<id***(uncurry filter<<<(((((/=0).).flip mod).head)&&&tail)))).snd))[3,5..]
main = print $ take 20 primes

[2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71]

で, でけたー！

お魚さん<+<を使うと

import Control.Arrow
infixr 2 <+<
(<+<) op f = arr (uncurry op) <<< f
primes = 2:(loop$uncurry(flip($))&&&curry((:)<+<(head.snd)&&&(($)<+<id***(filter<+<((/=0).).flip mod.head&&&tail))).snd)[3,5..]
main = print $ take 20 primes

なんかcurryしたりuncurryしたり忙しいけどまぁいいや.

あ, そう言えば,

curry f = (f.) . (,)

が成り立ちますから, (,)と(.)でcurryって消せるんですよね.

primes = 2:(loop$uncurry(flip($))&&&((((uncurry(:)<<<(head.snd)&&&(uncurry($)<<<id***(uncurry filter<<<(((((/=0).).flip mod).head)&&&tail)))).).(,)).snd))[3,5..]

fixからloopへの書き換えについて

fix f ==> loop (\(n, g) -> (g n, f g))

についてちょっと言っておきます. 直感的なものですが. fixの定義は

fix f = f (fix f)

というのはつまり, fix fという関数がfの不動点だ, ということです. よって

foo x = fix f x

とは, fの不動点にxを適用した値となります.

一方, loopの方は

loop f b = let (c,d) = f (b,d) in c

ですから,

loop (\(n, g) -> (g n, f g)) x
  = let (c,d) = (\(n, g) -> (g n, f g)) (x,d) in c
  = let (c, d) = (d x, f d) in c

となりますが, let d = f d, これは, dがfの不動点となります. んで, c = d xですから, 結果的にfの不動点にxを適用した値... と言うことはfix fと同じですね.

結論

ArrowLoopで再帰関数を書き直せるって言うことは, つまりその, えっと, どういうことでしょう(´・ω・｀)
構造化定理の三つ目だ！！！( ´∀｀)
なんかすごいことらしいです. ごめんなさい, よく分からなくて...