FibBuzz を Control.Arrow で解いてみた

Haskell

何か FizzBuzz 問題をちょっとだけパワーアップさせたものに FibBuzz とかいうのがあるそうで、0 から 100 までの整数を FizzBuzz する代わりにフィボナッチ数の各項に対して FizzBuzz する問題なようです。


面白そうなので久々に Control.Arrow を引っ張り出してやってみました。
ラムダ式使わずポイントフリースタイルで書いてます。この辺は基本ですね。

import Control.Arrow
import Data.Function (on)

fib = loop (((fst >>> uncurry (on (.) (:))) &&& (snd &&& fst >>> app) >>> app) &&& (snd >>> (snd &&& uncurry (+) >>>) >>> (uncurry (+) &&&) >>> (>>> uncurry (:)))) (0,1)

fizzBuzz = ((`mod` 3) &&& (`mod` 5) >>> f) &&& id >>> app
  where
    f (0,0) = const $ Left "FizzBuzz"
    f (_,0) = const $ Left "Buzz"
    f (0,_) = const $ Left "Fizz"
    f (_,_) = Right

fibBuzz = arr (flip take fib >>> map fizzBuzz) >>> Kleisli (mapM_ (runKleisli (Kleisli putStrLn +++ Kleisli print)))

main = runKleisli fibBuzz 30

FizzBuzz
1
1
2
Fizz
Buzz
8
13
Fizz
34
Buzz
89
Fizz
233
377
Buzz
Fizz
1597
2584
4181
FizzBuzz
10946
17711
28657
Fizz
Buzz
121393
196418
Fizz
514229

loop 関数を初めて使ったので全く意味が分からなかったのと、mapM_ の中で Kleisli な関数を呼び出す方法で結構悩みました。


これぐらいのコードならさくっと書けるようにしたいところ。

fib 関数の Arrow 化について

fib 関数の部分だけ、ちょっとずつ Arrow 化していく様子を書いていこうと思います。
元の関数はこんな感じ。

fib = loop f (0,1)
  where f (p@(x,y),g) = (x:y:g p, f' g)
        f' g (x,y) = let z = x+y in z:g (y,z)

もうこの時点で大分あれな感じですが、とにかく最初はこんなコードでした。
で、まずは f 関数をいくつかのパーツに分解します。

-- f (p@(x,y),g) = (x:y:g p, f' g)
-- f ((x,y),g) = (x:y:g (x,y), f' g)
f p = ((f1 (fst p)) (f2 p), f' (snd p))
f1 (x,y) xs = x:y:xs
f2 ((x,y),g) = g (x,y)

これは f 関数を適当に分解しただけです。
で、これをそれぞれ Arrow にしていきます。

-- f x = ((f1 (fst x)) (f2 x), f' (snd x))
f = ((fst >>> f1) &&& f2 >>> app) &&& (snd >>> f')

-- f1 (x,y) xs = x:y:xs
-- f1 (x,y) = (x:).(y:)
f1 = uncurry (on (.) (:))

-- f2 ((x,y),g) = g (x,y)
f2 = snd &&& fst >>> app

となります。
なので f 関数を Arrow にした状態は

fib = loop f (0,1)
  where f = ((fst >>> uncurry (on (.) (:))) &&& (snd &&& fst >>> app) >>> app) &&& (snd >>> f')
        f' g (x,y) = let z = x+y in z:g (y,z)

になります。


次に f' 関数です。例によって幾つかのパーツに分けます。

-- f' g (x,y) = let z = x+y in z:g (y,z)
-- f' g (x,y) = (x+y):g (y,(x+y))
f' g p = f1' p:f2' g p
f1' (x,y) = x+y
f2' g (x,y) = g (y,(x+y))

で、Arrow 化していきます。 g もいきなりポイントフリースタイルにすると間違えそうなので、まずは g 以外をポイントフリースタイルにしつつ Arrow 化します。

-- f' g p = f1' p:f2' g p
f' g = f1' &&& f2' g >>> uncurry (:)

-- f1' (x,y) = x+y
f1' = uncurry (+)

-- f2' g (x,y) = g (y,(x+y))
f2' g = snd &&& uncurry (+) >>> g

で、g も消します。

-- f' g p = f1' p:f2' g p
-- f' g = f1' &&& f2' g >>> uncurry (:)
f' = f2' >>> (f1' &&&) >>> (>>> uncurry (:))

-- f1' (x,y) = x+y
f1' = uncurry (+)

-- f2' g (x,y) = g (y,(x+y))
-- f2' g = snd &&& uncurry (+) >>> g
f2' = (snd &&& uncurry (+) >>>)

ということで、f' 関数を Arrow 化した状態は

fib = loop f (0,1)
  where f = ((fst >>> uncurry (on (.) (:))) &&& (snd &&& fst >>> app) >>> app) &&& (snd >>> f')
        f' = (snd &&& uncurry (+) >>>) >>> (uncurry (+) &&&) >>> (>>> uncurry (:))

となり、全部繋げると

fib = loop (((fst >>> uncurry (on (.) (:))) &&& (snd &&& fst >>> app) >>> app) &&& (snd >>> (snd &&& uncurry (+) >>>) >>> (uncurry (+) &&&) >>> (>>> uncurry (:)))) (0,1)

になります。やったねたえちゃん！