ようこそ。睡眠不足なプログラマのチラ裏です。

圏論でアハ体験

もう1週間以上前になりますが、Code2012という合宿イベントに参加してきました。いろいろな方との交流あり、温泉あり、クラウディアさんありと大変楽しかったので、ぜひ来年も参加したいです。


で、VBerのくせにそちらで「5分じゃわからないモナド - 圏論なんて華麗にスルー」というタイトルでLTをしてきました。なぜか、宴会の後にLTをやるという謎なタイムスケジュールとなっていたため、十分にアルコールが回った状態でお話をしました。時間通りにジャスト5分で話しきれたのは奇跡です。来年はそのあたり考慮してもらいたいかも...しれません。LTの後にいくつか質問をいただいて、モナドや圏やF#についてなんだか結構な時間追加でしゃべったような気がします。



LTの要点としましては、「モナドを使うのに圏論の知識は必要ない。」という意見はまったくそのとおりなのだけど、だからといって関数型言語を学ぶ人が圏論に触れることを無駄とは言えないということ。「プログラミングでモナドを使えるようになってから関数型言語の数学的背景であるところの圏論に触れてみることは、ぜんぜん無駄ではなかったし、むしろ思っていた以上に収穫があった!」という体験について伝えたい。「モナドは単なる自己関手の圏におけるモノイド対象だよ。」の意味を理解できるのとできないのとでは、見える景色がだいぶ違ってくる。圏論にはアハ体験があります。ある程度根気は必要だけど...ということを伝えたかったというものです。



当日話した内容とまったく同じではありませんが、大体以下のような内容でしゃべってきました。こわい人にこわいこわいされるのがこわいので、当初Webにはアップしないでおこうと考えていたのですが、いろいろと思うところが有り、思い直して現時点の自分の考えを晒しておくことにしました。かなり端折り気味な内容ですが雰囲気だけでも。



5分じゃわからないモナド - 圏論なんて華麗にスルー



5分じゃわからないモナド 始めさせていただきます。




ぜくるです。
静的型付け関数型言語が大好きです。 F#が大好きです。




美しいコードは好きですか?




もちろん大好きですよね!!!




美しいコードを書きたければ、より多くの良いコードを読まなければなりません。




ならば、関数型言語が読めないのは、あまりにも損です。




じゃいつやるか?今でしょ!




モナド。みなさん聞いたことくらいはありますよね。




モナドは単なる自己関手の圏におけるモノイド対象だよ。何か問題でも?




どういうことだってばよ!?




関数型言語を成り立たせている構造がそもそも圏だよ。
プログラミングとは、だいたいクライスリ圏の射を作ることらしいよ。




数学由来の抽象であるところの、代数的な構造をプログラミングに応用したらしいよ。




モナドは単なる自己関手の圏におけるモノイド対象だよ。何か問題でも?」
の意味がなんでわからんのかというと、そもそも専門用語がわからんからにほかならない。




4年くらい関数型言語を勉強してきた中で、わたしがモナドをわかるまでにやったこと。




まずは具体的にモナドを使ったプログラムを書きまくります。
野性的なプログラマはだいたい体で覚えます。




慣れてくると自分で定義します。より理解が深まります。
自分で考えた新しいモナドを定義することもできるようにもなります。




モナドを使うだけなら、高度な理論は全く必要ないんです。
モナドを使いこなすのに「圏論の知識なんて必要ない」そのとおりだと思います。




でも、最小限把握しておいたほうがよい用語や概念があります。
俺達プログラマは好奇心旺盛だもんね!




少し遠回りをしてもいいんじゃないか。
モナドの数学的な背景すべてを知らなくても、おおまかに概観を把握するだけで見える景色が違ってくる。




圏論に触れてみることにしました。




とりあえず、専門書に当たってみる。今年の正月からコツコツと勉強しています。
でも、この本はジャンル的に少し偏っているし、1,2章でお腹いっぱいです。




で、気づいたのが、そもそも群の知識がないと圏論を理解するのは困難ということです。




基礎の基礎が大事です。




集合や群を理解するために、代数を勉強をします。この時点でかなり遠回り。でも、いいんです。

圏論の本にも頻出する集合や群に関する記号の意味を理解するのに役立つ。穴埋めの練習問題形式。
やさしい入門書ですが、基本的なことや記号の意味を把握するだけならこれで十分だと思いました。
でも、マグマとか半群とかモノイドの説明はないので、それらは別の書籍などで補う必要がある。
思いの他おもしろかったので、気持ちに余裕があったら高度な内容にも挑戦してみたいかも。




群と言えばガロア置換群もプログラミングに関係が深いと感じました。
解説がわかりやすいだけではなく、数学の歴史的な背景も合わせて読めるからお得。
タイトル通り、中1でも読める内容なので安心です。でも後半は結構面倒くさいです。




代数的構造とはなんなのか。具体例を交えてわかりやすく解説してくれます。群の教科書。
こちらおすすめです。寝る前に読んだら、ぐっすり眠れます。




で、群・環・体...と、代数的構造にも色々とありますが、結局プログラミングに関係の深いのは、モノイドという構造です。
どうやら、プログラマ的には、モノイド以外の代数的構造については華麗にスルーしても問題なさそうです。




で、圏とはなんだったのか。
対象と射の集まりのことです。




ただし、ひとつの恒等射が必要。




また、合成射について、結合律を満たす必要があります。




モナド則ととっても似ていますね。
というかむしろ、モノイドの構造そのものです。




「圏」と同時に最小限知っておかなきゃなんないのが、「関手」です。
圏から圏への写像のことです。




自己関手。同一の圏から圏への関手のこと。
そのまんまですね。




Haskellプログラムは、圏(Hask圏)の中で動いています




F#のプログラムは、.NETの圏の中で動いています




どういうことなの?




F#のコードです。FSharpxというライブラリのMaybeモナドを使ってモナド則をコードで表現してみます。




モナド則を満たすわけですから、これは単位律と結合律を満たします。




モナドを使わずに、ただの関数で同様の表現をしてみます。
恒等射はidですね。




同じく単位律と結合律を満たします。




完全に一致!!!
いずれも、圏の条件を満たしており、それぞれが圏だということがわります。




圏空気すぎワロタ






F#の世界の値と関数は、.NETの圏からMaybeモナドの圏への写像であるところの「関手」return によって、 Maybeモナドの圏の値と関数に写像することができる。
で、Maybeの圏はこのとき.NETの圏に含まれていますから、自己関手の圏になるわけですね。で、Maybeという代数的データ型はモノイドの構造を持っているモノイド対象ということですね。




つまり、プログラミングのモナドというのは、関手 return を使うことで、.NETの圏の中で、自己関手の圏であるところのさまざまなモナドの圏を扱えるようになるんですね。






圏論なんて華麗にスルーして、まずモナドを使えるようになったほうがいいです。




ほら、5分じゃわからなかったでしょう?

はじめの一歩。まずはパイプライン演算子と合成演算子から。

今月末の7月28日、29日と、Code2012という合宿イベントに参加する予定です。F#や関数型について語り合える人がいない場合は割とボッチになりそうな気もしていますが...、それならそれで適当に楽しんでこようと思っています。というわけで、いつものように「月末になったらブログ書こう...」と後回しにしていると、なにも書かずじまいで終わっちゃいそうな気がするので、心に余裕のあるうちになんか書いておきます。

わたしはこれでF#覚えました。これが上達の鍵です。えっと、割とマジです。



F#でZ会三年生中学受験コース5月のてんさく問題

さて、話はちょっと変わって、「Z会三年生中学受験コース5月のてんさく問題」というのをF#で書いてみます。



元ネタ
Z会三年生中学受験コース5月のてんさく問題を Scala で解いてみた - terazzoの日記
http://d.hatena.ne.jp/terazzo/20120708/1341775360

4けたの数について、それぞれの位の数字を大きいじゅんにならべた数から小さいじゅんにならべた数をひくという計算を行います。
1974 について、この計算を 100 回行った答えを書きなさい。

Z会三年生中学受験コース5月のてんさく問題を Python で解いてみた - cooldaemonの備忘録

とりあえず書いた。

  let tensaku = 
    let subAscFromDesc x = 
      let s = (string x).ToCharArray() |> Seq.map string
      let toInt x = String.concat "" x |> int
      let flip f x y =  f y x
      toInt(List.sortWith (flip compare) (Seq.toList s)) - toInt(Seq.sort s)
    [1..100] |> Seq.fold (fun x _ -> subAscFromDesc x) 1974

  printfn "%d" tensaku


この手のコードを書いていつも思うのが、誰もが必要としそうな関数があらかじめ標準的に用意されているか否かで、書き易さが俄然違ってくるということ。F#では標準の範囲内で文字列操作が扱いやすいとは決して言えない感がある。あと、compare関数がデフォであるのはうれしいんだけど、ならflip関数もデフォで欲しいような気もする。



ちょっと書き換える。sortWithを使わずに昇順で並べたものをreverseするようにしただけ。

  let tensaku = 
    let subAscFromDesc x = 
      let s = (string x).ToCharArray() |> Seq.map string
      let calc x = String.concat "" >> int |> fun f -> f (List.rev (Seq.toList x) |> List.toSeq) - f x
      Seq.sort s |> calc
    [1..100] |> Seq.fold (fun x _ -> subAscFromDesc x) 1974

  printfn "%d" tensaku

Arrowの(&&&)演算子は関数を並列にする


元ネタでterazzoさんが、ScalazのArrow(関数のArrow)を使って書いていたので、同じくArrow使って書いてみたい。いつもならFSharpxをよっこらせと引き出してくるところであるが、残念ながらFSharpxにArrowはない。そういえばあそこにありましたねということで、某Arrowの実装をちょっと利用して書いてみる。

  let tensaku = 
    let sorted x = (string x).ToCharArray() |> Seq.map string |> Seq.sort  
    let toInt x = String.concat "" x |> int
    let rev = Seq.fold (fun acc e -> Seq.append (Seq.singleton(e)) acc) Seq.empty 
    let sub (x,y) = x - y 

    let subAscFromDesc = 
      string >>> sorted >>> ((rev >>> toInt) &&& toInt) >>> sub
    [1..100] |> Seq.fold (fun x _ -> subAscFromDesc x) 1974

  printfn "%d" tensaku

これがArrowのちからか。もし出来合いのsorted、toInt、rev、subの関数があったならば、3行で書けちゃうとか。欲張ればワンライナーでもイケちゃいますね、みたいな。「でもそれ読みやすいか?」って言われると、大半の人は横に首を振ると思う。しかしながら、Arrowというのは別に読みにくいコードを書くためのものではない。なにか計算の本質的な部分を表しているような雰囲気がある。で、この例で特にミソとなるは、(&&&)演算子の部分で、昇順ソートと降順ソートの結果をタプルにまとめている部分。つまり、2つの関数を並列に繋いでいるところがミソ。ってまぁArrowとかよくわかっていませんが。



ちなみにHaskellのArrowの定義はこちら。

class Arrow a where
arr :: (b -> c) -> a b c
pure :: (b -> c) -> a b c
(>>>) :: a b c -> a c d -> a b d
first :: a b c -> a (b, d) (c, d)
second :: a b c -> a (d, b) (d, c)
(***) :: a b c -> a b' c' -> a (b, b') (c, c')
(&&&) :: a b c -> a b c' -> a b (c, c')


もちょっと手を加えてみる。ループを内側によっこしただけ。

  let tensaku = 
    let sorted x = (string x).ToCharArray() |> Seq.map string |> Seq.sort  
    let toInt x = String.concat "" x |> int
    let rev = Seq.fold (fun acc e -> Seq.append (Seq.singleton(e)) acc) Seq.empty 
    let sub (x,y) = x - y 
    let loop st so f = Seq.fold (fun x _ -> f x) st so

    let subAscFromDescLoop st so = 
      string >>> sorted >>> ((rev >>> toInt) &&& toInt) >>> sub |> loop st so
    [1..100] |> subAscFromDescLoop 1974

  printfn "%d" tensaku


で、Arrowを用いて書いてみたわけですが、ここで言うArrowは関数のArrowなので、別に某Arrowの実装を使う必要は全くなくて、ちょっとした工夫をして以下のようにするだけで同じことができる。

  let tensaku = 
    let sorted x = (string x).ToCharArray() |> Seq.map string |> Seq.sort  
    let toInt x = String.concat "" x |> int
    let rev = Seq.fold (fun acc e -> Seq.append (Seq.singleton(e)) acc) Seq.empty 
    let sub (x,y) = x - y 
    let loop st so f = Seq.fold (fun x _ -> f x) st so
    let (&&&) f g = (fun x -> x, x) >> (fun f (a,b) -> f a,b ) f >> (fun f (a,b) -> a,f b) g

    let subAscFromDescLoop st so = 
      string >> sorted >> ((rev >> toInt) &&& toInt) >> sub |> loop st so
    
    [1..100] |> subAscFromDescLoop 1974

  printfn "%d" tensaku


このように関数のArrowにおいては、(>>>)演算子は、ただの関数の合成を意味しているので(>>)合成演算子にそのまま置き換えられるし、(&&&)演算子も上記のように割かし簡単に定義することができる。関数の合成という基本知識の範囲内で同じことができる。うんArrowが計算の本質的な部分を表しているような雰囲気があったのはこのためだね。



F#の上達法



パイプライン演算子についてはここであらためて説明する必要もない気もしますが、簡単に。(|>)パイプライン演算子という中置演算子を用いることで、関数と引数の順序を逆にすることができます。これによって、関数適用の流れを手続き型的に表現することができるというものです。F#ではこの「パイプライン演算子を使う」ことが基本でありながら、同時に最上級のプラクティスであると言っても過言ではなく。これを好んでよく使うことはおのずとF#の上達に繋がります。もう一つ、この記事でもたくさん使用した(>>)合成演算子で関数を合成する練習を行うのも良い。これは関数型プログラミングの基本的な考え方のひとつを身に着けるのに役立つ。他にも、mapしろだfoldしろだと上達のための"はじめの一歩"はいろいろとある。いきなりモナドとかゆー壮大な抽象概念に飛び込まなくたって関数型の魅力とパワーはそこかしこにあるし、まずは小さなことからコツコツと。中には飛び級できちゃう人もいるけどね。


関数型言語を用いた関数型プログラミングには、「今のはメラゾーマではない、メラだ 」がそこかしこに溢れているね!!!ダイの大冒険とかテラ夏カシスだね!!!



ところで、小学生的にはこのZ会の問題をどうやって解くのかな。と思ったのですが、実の所これ5回操作をすると6174(7641-1467=6174)に結果が収束するんですよね。ということで、今回定義した関数はメモ化しておいた方がよかったのか?どうでもいいね。

F#で shift/reset プログラミング。限定継続(風)モナドで四天王問題を解く。


発売されてすぐにPSVitaのP4Gをダウンロードしたのだが、どちらかというとエヴィディ・ヤングライフ・VB6♪な生活を送っていてなかなかプレイする暇がなくてつらい。今日はGoAzureのゆーすと見たり、この記事をこしらえていたりな休日を過ごしていましたが、皆さんいかがお過ごしでしょうか。


限定継続と shift/resetプログラミング

少し前に書籍「Scala実践プログラミング」のChapter10-2 継続のところ読んでいて、限定継続面白いなー shift/reset プログラミング面白いなーと思っていたので、shift/reset プログラミングについて検索してみました。すると、書籍「プログラミングの基礎」でも有名な、お茶の水女子大学の浅井健一氏の「shift/reset プログラミング入門」が出てきました。いきなり当たりを引いた!今日のおれはツイてるな!(テッテレー)と言う感じで、こちらとてもわかりやすくて素晴らしい資料です。関数型プログラミングや限定継続に興味のある方はぜひご一読を。




Scalaでは限定継続のサポートにより、以下のように shift/resetプログラミングをすることができます。

// result: 11
reset {
    shift { k: (Int=>Int) =>  k(10)
    } + 1
}

継続を限定しているreset部分について、shiftでその継続を取り出して k に束縛していて、 その k に 10 を適用することによって、1が加算されるので、結果は11になります。限定継続ってなんぞ?これの何が嬉しいのかわからないだって?まぁまぁそうおっしゃらずに。とりあえず「shift/reset プログラミング入門」を読みましょう。話はそれから。



ところで、Scala 2.8からサポートされたらしい限定継続ですが、F#にはいまのところそのような機能はないですし今後もサポートされる可能性は低そうです。でも、F#でちょっと真似してみたくなるよね。 shift/reset プログラミングちょっとあこがれちゃうよね。ということで、限定継続(風)モナドを作って F#でshift/reset プログラミングの雰囲気を感じてみましょう。



限定継続(風)モナド
ここで示すモナドはまぎれもなくモナドであるし、限定継続を意識した shift/reset なスタイルでプログラミングをすることができるようになるけど、いわゆるcall/cc的なことはしていませんので厳密には限定継続とは言えないので、限定継続(風)であるということに注意してください。F#でのモナド表現には、コンピューテーション式および、とてもCoolなライブラリFSharpxを利用しました。

namespace Monad.DCont

// 限定継続()モナド
[<AutoOpen>]
module DCont =
  open FSharpx

  type DCont<'a,'b,'c> = DCont of (('c -> 'a) -> 'b) 

  let dcontreturn x = fun k -> k x
  let shift f = fun k -> f (fun s -> dcontreturn <| k s) id

  type DContBuilder() =
    member this.Return(x) = dcontreturn x
    member this.ReturnFrom(m) = m
    member this.Bind(m, bind) =
      fun k -> m <| fun s -> bind s k 
    member this.Zero() = shift(fun _ -> id)
    member this.Combine(c1, c2) = this.Bind(c1, fun _ -> c2)
    member this.Delay(f) = f()
    member this.For(seq, f) = 
      Seq.fold
        (fun cc elem -> this.Combine(cc, f elem))
        (f <| Seq.head seq) <| Seq.skip 1 seq

  let reset = DContBuilder()
  let runDCont (f) = f id

  open Operators
  let inline returnM x = returnM reset x 
  let inline (>>=) m f = bindM reset m f
  let inline (=<<) f m = bindM reset m f
  let inline (<*>) f m = applyM reset reset f m
  let inline ap m f = f <*> m
  let inline map f m = liftM reset f m
  let inline (<!>) f m = map f m
  let inline lift2 f a b = returnM f <*> a <*> b
  let inline ( *>) x y = lift2 (fun _ z -> z) x y
  let inline ( <*) x y = lift2 (fun z _ -> z) x y
  let inline (>>.) m f = bindM reset m (fun _ -> f)
  let inline (>=>) f g = fun x -> f x >>= g
  let inline (<=<) x = flip (>=>) x

  let dcont f = fun x -> returnM <| f x 
  let shift' k = fun x -> 
    reset { let! a = k x
            return a}


モナド則の確認とか

namespace MonadicRetry.Test
open System

[<AutoOpen>]
module Tests = 
  open NUnit.Framework
  open FsUnit
  open Monad.DCont
      
  [<TestFixture>]
  type ``モナド関連確認`` () =
    let x = 1
    let m = reset { return 8 }
    let f x = reset { return 4 + x }
    let g x = reset { return 3 * x }

    let assertEqual (left, right) = 
      reset {let! a1 = left
             let! a2 = right
             let r = (a1 |> should equal (a2))
             printfn "%s" (sprintf "%d = %d , Result :%b" a1 a2 ((a1) = (a2)))
             return fun () -> 0} |> runDCont |> ignore

    let (==) left right = assertEqual (left, right)

    [<Test>] 
    // モナド則1: return x >>= f == f x
    member test.``01.モナド則1`` () =
      returnM x >>= f == f x 

    [<Test>] 
    // モナド則2: m >>= return == m
    member test.``02.モナド則2`` () =
      let m' = m >>= returnM
      m' == m

    [<Test>] 
    // モナド則3: (m >>= f) >>= g == m >>= (\x -> f x >>= g)
    member test.``03.モナド則3`` () =
      (m >>= f) >>= g == (m >>= (fun x -> f x >>= g))

    // Functor(関手)
    [<Test>] 
    //fmap id == id
    member test.``04.関手:functor1`` () =
      map id m == m

    [<Test>] 
    //fmap (f.g) == fmap f . fmap g
    member test.``05.関手:functor2`` () =
      let f x = x * 2 
      let g x = x + 2 
      m |> map (f >> g) == (m |> (map f >> map g))

    [<Test>] 
    // fmap :: (a -> b) -> f a -> f b
    // fmap f m == m >>= return . f
    member test.``06.関手:functor3`` () =
      let f x = x * 2 
      (map f m) == (m >>= (f >> returnM))

    // アプリカティブ: f <!> m1 <*> m2 == m1 >>= fun x -> m2 >>= fun y -> return f x y
    [<Test>] 
    member test.``07.アプリカティブ:applicative1`` () =
      let f x y = x * 2 + y * 2
      let m1 = reset { return 6 }
      let m2 = reset { return 9 }
      f <!> m1 <*> m2 == reset { let! a = m1
                                 let! b = m2
                                 return f a b }

    [<Test>] 
    member test.``08.アプリカティブ:applicative2`` () =
      let f x y z = x * 2 + y * 2 - z
      let m1 = reset { return 6 }
      let m2 = reset { return 9 }
      let m3 = reset { return 20 }
      f <!> m1 <*> m2 <*> m3 == reset { let! a = m1
                                        let! b = m2
                                        let! c = m3
                                        return f a b c}

    // Kleisli[<Test>] 
    member test.``09.クライスリ圏:kleisli composition1`` () =
      let x = 10
      let f x = 
          if x > 5
              then reset { return "hello" }
              else reset { return "world" }
      let g x =
          if x = "hello"
              then reset { return 777 }
              else reset { return 0 }
      (f x >>= g) == (f >=> g <| x)

  // nunit-gui-runner
  let main () = NUnit.Gui.AppEntry.Main([|System.Windows.Forms.Application.ExecutablePath|]) |> ignore
  main ()


ホンモノの限定継続モナドは、きっと腕の立つF#マスター達が実装してくれるんじゃないかな。期待しましよう。



限定継続(風)モナドを利用してみる

さっそく利用してみる。さきほどのScalaの限定継続の例を、限定継続(風)モナドをつかって、F#で書いてみます。

reset {let! a = shift(fun k -> k 10) 
       return a + 1 } 
|> runDCont |> printfn "%d"


意図通りに、11って出力される。コンピューテーション式でモナドを表現しているので、根本的には違うものの割とScalaと似たようなスタイルで記述できていい感じ。なんとなく雰囲気が醸し出せているね。雰囲気重視だよ!!!



限定継続(風)モナドで四天王問題


元ネタ
Scalaの限定継続で四天王問題を解いてみた - papamitra
http://d.hatena.ne.jp/papamitra/20100912/continuations


おお、あの四天王問題ですか。限定継続でAbmへの応用とかって面白いですね。



四天王問題

A「Dがやられたようだな…」B「ククク…奴は我ら四天王の中でも最弱…」C「私はBよりも弱い…」A「そして私は最強ではない…」B「四天王の中に私よりも弱いものが最低でも二人いる…」C「私はAよりも強い…」 ※以上の条件から四天王を強い順に並べよ(5点)


これを限定継続(風)モナドでF#で書くとこう

namespace TheBigFourProblem

module Program =
  open System
  open Monad.DCont
  open Monad.DCont.Amb

  let abcd () =
    reset {
      let numbers = [1;2;3;4]
      let! a = amb numbers
      let! b = amb numbers
      let! c = amb numbers
      let! d = amb numbers

      // 同じ強さではないことを仮定
      do! distinct [a;b;c;d] |> require

      // ADがやられたようだな…」B「ククク…奴は我ら四天王の中でも最弱…」
      do! d = 4 |> require

      // C「私はBよりも弱い…」
      do! b < c  |> require

      // A「そして私は最強ではない…」
      do! a = 1 |> not  |> require

      // B「四天王の中に私よりも弱いものが最低でも二人いる…」
      do! (b = 1 || b = 2) |> require

      // C「私はAよりも強い…」
      do! c < a  |> require

      // ※以上の条件から四天王ABCDを強い順に並べよ(5点)
      printfn "%s" <| sprintf "A:%d,B:%d,C:%d,D:%d" a b c d
    } 

  abcd ()
  |> runDCont
  |> ignore


実行結果

A:3,B:1,C:2,D:4


open Monad.DCont.Amb ってなんぞ? 限定継続(風)モナドでAmbを利用するために以下のようなmoduleを作って利用しています。

namespace Monad.DCont

module Amb =
  open System

  let rec amb list = 
    reset {
      if List.isEmpty  list then
        return! shift(fun _ -> returnM (List.empty))
      else
        return! shift(fun k -> k (List.head list) |> ignore
                               reset.Bind(amb (Seq.toList <| Seq.skip 1 (List.toSeq list)), k))
    } 

  let require p = reset { return! shift(fun k -> if (p) then (k ()) else shift(fun _ -> id)) }

  let distinct list = 
    let rec proc list = 
      match list with
      | x :: xs -> List.toArray xs |> fun a -> 
        if (Array.IndexOf(a,x)) < 0 && proc(xs) then 
          true 
        else false
      | _ -> true
    proc list 

元ネタ
Scalaの限定継続で四天王問題を解いてみた その2 - papamitra
http://d.hatena.ne.jp/papamitra/20100912/continuations2


もっと四天王問題!すこし難易度があがります。

A「Dがやられたようだな…」B「ククク奴は四天王でも最弱…」C「私はBよりも強い」A「私は最強ではないが最弱でもない」B「私はAより強いぞ」C「四天王NO.3は嘘つき」A「私とCとの実力差は離れている」 問:四天王を強い順に並べよ。但し正直者は真実、嘘つきは嘘しか言わないものとする。(100ポイント)

  let abcd2 () =
    reset {
      let numbers = [1;2;3;4]
      let! a = amb numbers
      let! b = amb numbers
      let! c = amb numbers
      let! d = amb numbers

      let! at = amb [true;false]
      let! bt = amb [true;false]
      let! ct = amb [true;false]
      let! dt = amb [true;false]

      // 同じ強さではないことを仮定
      do! distinct [a;b;c;d] |> require

      // // ADがやられたようだな…」B「ククク…奴は我ら四天王の中でも最弱…」
      do! ((bt && d = 4) || (bt |> not && d = 4 |> not)) |> require

      // C「私はBよりも強い」
      do! ((ct && c < b) || (ct |> not &&  b < c))  |> require

      // A「私は最強ではないが最弱でもない」
      do! ((at &&  (a = 1 |> not && a = 4 |> not)) || (at |> not && (a = 1 || a = 4))) |> require

      // B「私はAより強いぞ」
      do! ((bt && b < a) || (bt |> not && a < b)) |> require

      // C「四天王NO.3は嘘つき」
      do! (c = 3 |> not) |> require
      do! ((ct && ((at |> not && a=3) || (bt |> not && b=3) || (dt |> not && d=3))) || (ct |> not && ((at && a=3) || (bt && b=3) || (dt && d=3))))  |> require

      // A「私とCとの実力差は離れている」
      // 順位が隣合っていないと解釈する.
      do! ((at && (abs(a-c) = 1 |> not)) || (at |> not && (abs(a-c) = 1))) |> require

      // ※以上の条件から四天王ABCDを強い順に並べよ
      printfn "%s" <| sprintf "A:%A,B:%A,C:%A,D:%A" (a,at) (b,bt) (c,ct) (d,dt)
    } 

  abcd2 ()
  |> runDCont
  |> ignore

実行結果

A:(1, false),B:(4, false),C:(2, true),D:(3, false)


ちゃんと、四天王の強さの順番と、C以外は嘘つきであるという結果が導きだせましたね!




おまけ:ダイハード3のやつ
なんだか、非決定計算の問題を解くのが面白くなってきちゃったので、せっかくなので限定継続(風)モナドでどんどん解いていきます。


まずは、ダイハード3で出題された3ガロンと5ガロンの容器で4ガロンを量るってやつ。いわゆる、水差し問題とゆーやつですね。
これは、わざわざプログラミングで解くまでもないなぞなぞレベルの問いですが、書いてみます。

namespace PitcherProblem

module Program =
  open System
  open Monad.DCont
  open Monad.DCont.Amb

  // ダイハード3の 3ガロンと5ガロンの水差し問題
  let maxa = 5
  let maxb = 3

  let geta state = fst state
  let getb state = snd state

  let private action =
    [ // Aを満杯にする
      fun state -> maxa, getb state;
      // Aを空にする
      fun state -> 0, getb state;
      // AからBへ移す
      fun state -> 
        let a = geta state
        let b = getb state
        let w = maxb - b
        if a <= w then
          // 全部移しきった場合
          0, a + b
        else
          // Aに水が残る場合
          a - w, b + w;

      // Bを満杯にする
      fun state -> geta state, maxb;
      // Bを空にする
      fun state -> geta state, 0;
      // BからAへ移す
      fun state ->
        let a = geta state
        let b = getb state
        let w = maxa - a
        if b <= w then
          // 全部移しきった場合
          a + b, 0
        else
          // Aに水が残る場合
          a + w, b - w; ]
 
  let private solve answer = 
    let rec solve' n answer move =
      let x = (List.length move) - 1
      let prev = move.Item x 
      reset {
        if n = 0 && prev |> fst = answer || prev |> snd = answer then
            return! shift(fun k -> k move)
        else
            let! act = amb action
            let newstate = act prev
            let contains s list = List.exists(fun x -> x = s) list
            if prev = newstate || contains newstate move then
              return! shift(fun _ -> returnM move)
            else
              return! solve' (n-1) answer (move@[newstate]) }

    let m = List.length action
    solve' m answer [(0,0)]

  let pitcherProblem answer =
    let result = ref []
    reset {
      let! xs = solve answer
      result := !result@[xs]
      return xs
    } |> runDCont |> ignore
    !result

  pitcherProblem 4
  |> fun x -> x |> Seq.iter (printfn "%A")
              printfn "%s" <| sprintf "%d通り" x.Length


おまけ:地図の塗り分け

いかなる地図も、隣接する領域が異なる色になるように塗るには4色あれば十分DAZEという、いわゆる四色定理とゆーやつ。
実際に塗り分けしてみよう。

namespace ColorMapProblem

module Program =
  open System
  open Monad.DCont
  open Monad.DCont.Amb

  let colorMapProblem () =
    reset {
      let colors = ["red";"yellow";"green";"blue"]
      let! p = amb colors // Portugal:ポルトガル
      let! e = amb colors // Spain:スペイン
      let! f = amb colors // France:フランス
      let! b = amb colors // Belgium:ベルギー
      let! h = amb colors // Holland:オランダ
      let! g = amb colors // Germany:ドイツ
      let! l = amb colors // Luxemb:ルクセンブルク
      let! i = amb colors // Italy:イタリア
      let! s = amb colors // Switz:スイス
      let! a = amb colors // Austria:オーストリア

      let notcontains s list = List.exists(fun x -> x = s) list |> not
      // ポルトガルは、[スペイン]の色と違うよ
      do! notcontains p [e] |> require
      // スペインは、[フランス;ポルトガル]の色と違うよ
      do! notcontains e [f;p] |> require
      // 以下コメント略
      do! notcontains f [e;i;s;b;g;l] |> require
      do! notcontains b [f;h;l;g] |> require
      do! notcontains h [b;g] |> require
      do! notcontains g [f;a;s;h;b;l] |> require
      do! notcontains l [f;b;g] |> require
      do! notcontains i [f;a;s] |> require
      do! notcontains s [f;i;a;g] |> require
      do! notcontains a [i;s;g] |> require

      // 4色で塗り分ける組み合わせ
      printfn "%s" <| sprintf "Portugal:%s,Spain:%s,France:%s,Belgium:%s,Holland:%s,Germany:%s,Luxemb:%s,Italy:%s,Switz:%s,Austria:%s" p e f b h g l i s a
    } 

  colorMapProblem ()
  |> runDCont
  |> ignore


想像以上に塗り分けれるね!



おまけ:狼とヤギとキャベツ

いわゆる川渡り問題。

オオカミとヤギを連れキャベツを持った農夫が川岸にいる。川にはボートがあるが農夫の他には動物一頭かキャベツ一玉しか乗せられない。農夫がいなければオオカミはヤギを襲うし、ヤギはキャベツを食べてしまう。すべてを無事に対岸に渡すにはどうしたらよいか?

namespace FarmerGoatWolfCabbage

module Program =
  open System
  open Monad.DCont
  open Monad.DCont.Amb

  type Position = 
    | Left of Kind 
    | Right of Kind
  and Kind =
    | Farmer
    | Goat
    | Wolf 
    | Cabbage
  
  let swap = function | Left x -> Right(x) | Right x -> Left(x)
  let init = Left(Farmer), Left(Goat), Left(Wolf), Left(Cabbage)
  let ans = Right(Farmer), Right(Goat), Right(Wolf), Right(Cabbage)
  
  let (==) x y =
    match x,y with
    | Left _, Left _   -> true
    | Right _, Right _ -> true
    | _,_ -> false

  let private action =
    [ 
      // 農夫のみ移動
      fun state -> let f, g, w, c = state
                   swap f, g, w, c;
      // 農夫とヤギ
      fun state -> let f, g, w, c = state
                   swap f, swap g, w, c;
      // 農夫と狼
      fun state -> let f, g, w, c = state
                   swap f, g, swap w, c;
      // 農夫とキャベツ
      fun state -> let f, g, w, c = state
                   swap f, g, w, swap c;
      ]

  let safe state =
    let safegote = 
      let f,g,w,c = state
      if f == g then true
      else g == w |> not
    let safecabbage = 
      let f,g,w,c = state
      if f == c then true
      else g == c |> not
    safegote && safecabbage

  let private solve () = 
    let rec solve' move =
      let x = (List.length move) - 1
      let prev = move.Item x 
      reset {
        if prev = ans then
            return! shift(fun k -> k move)
        else
            let! act = amb action
            let newstate = act prev
            let contains s list = List.exists(fun x -> x = s) list
            if prev = newstate then  
              return! shift(fun _ -> returnM move)
            elif contains newstate move then
              return! shift(fun _ -> returnM move)
            elif  (safe newstate |> not) then
              return! shift(fun _ -> returnM move)
            else
              return! solve' (move@[newstate]) }

    let m = List.length action
    solve' [init]

  let farmerGoatWolfCabbageProblem () =
    let result = ref []
    reset {
      let! a = solve ()
      result := a
      return a
    } |> runDCont |> ignore
    !result

  farmerGoatWolfCabbageProblem ()
  |> fun x -> x |> Seq.iter(fun x ->
    let f,g,w,c = x
    let result = [f;g;w;c]
    printf "["
    result |> Seq.filter (fun x -> x |> function | Left _ -> true | _ -> false) 
           |> Seq.map (fun x -> x |> function | Left x -> x | Right x -> x)  
           |> Seq.iter (printf "%A;" )
    printf "] : "

    printf "["
    result |> Seq.filter (fun x -> x |> function | Right _ -> true | _ -> false) 
           |> Seq.map (fun x -> x |> function | Left x -> x | Right x -> x)  
           |> Seq.iter (printf "%A;")
    printfn "]"
    )


実行結果

[Farmer;Goat;Wolf;Cabbage;] : []
[Wolf;Cabbage;] : [Farmer;Goat;]
[Farmer;Wolf;Cabbage;] : [Goat;]
[Wolf;] : [Farmer;Goat;Cabbage;]
[Farmer;Goat;Wolf;] : [Cabbage;]
[Goat;] : [Farmer;Wolf;Cabbage;]
[Farmer;Goat;] : [Wolf;Cabbage;]
[] : [Farmer;Goat;Wolf;Cabbage;]


わーい、無事に川を渡れたよ!



おまけ:順列と組み合わせ

今度はちょっと趣向を変えて。書いているうちに、だんだんshift/reset スタイルなプログラミングに慣れてきたかもな気がするよ!

namespace PermutationAndCombination

module Program =
  open System
  open Monad.DCont
  open Monad.DCont.Amb

  let rec private selections n m lst result =
    let contains s list = List.exists(fun x -> x = s) list
    reset {
      if m = 0 || lst = [] then
        return! shift(fun k -> k result)
      else
        return! reset {
          let! x = amb [0..n-1]
          if contains (lst.Item x) result then
            return! shift(fun _ -> returnM result)
          else
            return! selections n (m-1) lst (result@[lst.Item x])}
    }  

  // 順列
  let permutations m lst =
    let n = List.length lst
    let result = ref []
    reset {
      let! xs = selections n m lst []
      xs.Length = m |> function 
        | false -> ()
        | true -> result := !result@[xs]
      return xs
    } |> runDCont |> ignore
    !result

  permutations 4 ['A'..'F']
  |> fun x -> x |> Seq.iter (printfn "%A")
              printfn "%s" <| sprintf "%d通り" x.Length


  // 組み合わせ
  let combinations m (lst: 'a list) =
    let n = List.length lst
    let contains r sourece = 
      sourece |> Seq.map  (fun x -> (set x, set r) ||> Set.difference = Set.empty)
              |> Seq.exists id

    let result = ref []
    reset {
      let! xs = selections n m lst []
      contains xs !result |> function
      | true   -> ()
      | false  -> result := !result@[xs]
      return xs
    } |> runDCont |> ignore
    !result

  combinations 4 ['A'..'F']
  |> fun x -> x |> Seq.iter (printfn "%A")
              printfn "%s" <| sprintf "%d通り" x.Length


なんか、おまけの方が多くなっちゃいましたね。てへぺろ☆(・ω<)
Amb以外の応用例も書くつもりでしたが、積みゲー消化したいのでそれはまた別の機会に。たぶん。

F#3.0で加速する言語指向プログラミング(LOP)。コンピューテーション式はもはやモナドだけのための構文ではない!!!



マーチン・ファウラー先生の黒いDSL本(翻訳版)が5月2日に発売されました。遅ればせながら私も最近購入して熟読しているところです。


この本が示すDSLの種類や内容は、あくまでもオブジェクト指向というコンテキストにおいてのものであり、関数型言語によるDSL開発については一切言及はありませんが、まえがきの「本書に欠けていること」の中で「"関数型言語でのDSL"に関する言及はないので、ご了承ください。」というようなお断りがあり、好感が持てます。マーチン・ファウラー先生に限らず、オブジェクト指向の大御所たちも最近の関数型言語流行の流れにはとても敏感になっているようです。実際、ことDSLに関して言うなら、モナディックなパーサ・コンビネータの存在など、確かに関数型言語の方が有利になる点もいくつかあるし、それらについて書籍内に言及がないことを説明するのは良いことだと思う。この本で示されている考え方やパターンについて関数型言語ではどのように考え適用していけばよいのか。自分の中で消化していきたい。そんなこんなで、黒いDSL本が結構人気みたいです。日本のデベロッパーのDSLに対する関心の高まりを感じたり、ドラゴンズドグマが楽しみだったりな今日この頃ですが、いかがお過ごしでしょうか。

まだ読み終わっていないんですが書いちゃいます。
この記事では、「F#3.0ではコンピューテーション式が拡張されたので、内部DSLが作りやすくなりましたよ。」という話題を提供します。



言語指向プログラミング(LOP)とは

言語指向プログラミング(LOP)とは、メタプログラミングと同様にひとことで言い表すことは容易ではない抽象的な概念ですが、大きな意味で「ドメイン特化言語(DSL:Domain Specific Language)を使ってソフトウェア構築を行う一般的な開発スタイル」というように具体的に捉えることもできます。言語指向プログラミングを理解するには、まずDSLとは何かと言うことを理解する必要があります。



ある特定のドメイン(目的)の問題解決のために特化させた専用のプログラミング言語のことをDSLと言います。専用言語というとなんだか難しいように聞こえるかもしれませんが、実のところそんなたいした話ではなく、多くの場合はXML等の設定ファイルやライブラリ、あるいはフレームワークの延長上に自然と現れてくるものです*1。あらかじめDSLで開発すること考えて設計をできるのが理想的ですが、少し凝った設定ファイルが拡張を繰り返すたびにいつの間にかDSLのようなものになっていたというケースは現場ではそう珍しいことではないかもしれません。



ごく身近にあるDSLの例として、Excelのセル内の値は「A2」や「D5」などのように、Excel固有の表し方でシンプルに表す機能があります。これは、汎用プログラミング言語のようにデータの型などを記述することなく、「=A2+D5」などのように単純な式において値を計算をすることができます。これは特定の問題に対する専用言語として捉えることができ、つまり一種のDSLであると言えます。この例からもわかるように、DSLの主な利点は特定の問題に対して表現がとてもシンプルになるということです。このように特定の問題に対応するためにホスト言語とは別の言語を定義して、それを用いて特定ドメインの問題を解決しようとする考え方や手法。それを言語指向プログラミングと言います。



DSLには、大きく分けて外部DSLと内部DSLの2種類があり、ホスト言語*2とは異なる言語で作成するものを外部DSL(例えばXMLファイルなどを使用する手法。弾幕記述言語BulletMLなど。)といい、ホスト言語のサブセットで書かれるタイプのものを内部DSLあるいは組み込み型DSL(.NETのLINQなど)と呼びます。言語指向プログラミングで伝統的なものとしては、Unixリトル言語、Lisp、アクティブデータモデル、XML設定ファイルなどがあり、現在も様々な場面で広く活用されています。



言語指向プログラミングおよびDSL開発についてより詳しい情報が知りたい場合は、マーチン・ファウラー先生著の黒いDSL本こと「ドメイン特化言語 パターンで学ぶDSLのベストプラクティス46項目」を読むか、あるいは「LanguageWorkbench - Martin Fowler's Bliki in Japanese」あたりを参照されたい。



F#3.0で加速する言語指向プログラミング(LOP)。コンピューテーション式はもはやモナドだけのための構文ではない!!!



F#(F#2.0)は、強い静的型付き言語としては比較的言語指向プログラミングのやりやすい言語です。パターンマッチやアクティブパターンを利用して抽象的にDSLを定義する手法、XML設定ファイルを読み込んで外部DSLを作成する古典的な手法、コンピュテーション式を用いて計算式として内部DSLを作成する手法。モナディックなパーサ・コンビネータライブラリFParsecを利用して構文解析を行う手法、あるいはfslex/fsyaccを利用したコンパイラの作成など、その方法はさまざまです。


F#3.0で追加される2つの新機能によって、言語指向プログラミング(LOP)の手法の幅がさらに広がります。その1つは、ご存じTypeProvider。TypeProviderはコード生成と動的型付けの両方に替わるものとして発表当時から注目を集めています。この機能が追加された直接の目的とは異なりますが、外部DSLを作成する手法のひとつとしてTypeProviderが新たに加わりました。




もう1つは、Query expressions(クエリ式)です。クエリ式およびそのクエリメカニズムそのものがDSL作成について直接影響を与えるものではありませんが、新たにクエリ式の機能を提供するにあたって合わせて追加された仕様である「コンピューテーション式に、独自のキーワードを定義することができるカスタムクエリ拡張機能」が大きな影響を与えます。F#2.0ではコンピューテーション式において、 let!、do! 、return、return!などの特定のキーワードのみが利用可能でした。コンピューテーション式は、モナドを書くために限定された機能というわけではありませんでしたが、BindやReturnなどモナドの文脈として利用されるキーワードの色が強く、事実上モナドのための構文として利用されてきました。なぜなら、F#2.0ではコンピューテーション式で利用できるキーワードを拡張する方法が提供されていなかったからです。しかし、F#3.0のコンピューテーション式ではこれが拡張可能であり、CustomOperationAttributeクラスを用いることで独自のキーワードを定義することができ、ある程度柔軟なカスタマイズができます。これは大変エキサイティングなことです!!!




実際どういうことができるのかというと、以下のようなことが可能となります。

type SeqBuilder() =      
  member __.For (source, body) =        
    seq { for v in source do yield! body v }
  member __.Yield (item)= 
    seq { yield item }        
  [<CustomOperation("select")>]
  member __.Select (source, f)= 
    Seq.map f source   

let myseq = SeqBuilder() 

myseq { for i in 1 .. 10 do 
          select (fun i -> i + 100) }
|> Seq.iter (printfn "%d")


この仕組みの詳細については、まだ大々的に公表されているものではありませんが、MSDN - Core.CustomOperationAttribute クラス (F#)にて、ある程度利用方法を把握することができます。F#3.0で言語指向プログラミングが加速するとはつまりこういうことです。コンピューテーション式はもはやモナドだけのための構文ではないのです!!!




ProjectionParameterAttributeの利用

カスタムオペレーションの引数をProjectionParameter属性でマークすると、自動的にパラメーター化(というかカスタムキーワードに続く式を暗黙的に関数に変換)してくれる。

type SeqBuilder() =      
  member __.For (source, body) =        
    seq { for v in source do yield! body v }
  member __.Yield (item)= 
    seq { yield item }        
  [<CustomOperation("select")>]
  member __.Select (source, [<ProjectionParameter>] f) = 
    Seq.map f source  

let myseq = SeqBuilder() 

myseq { for i in 1 .. 10 do 
          select (i + 100) }
|> Seq.iter (printfn "%d")

MaintainsVariableSpaceプロパティの利用

CustomOperation属性のMaintainsVariableSpaceプロパティをtrueに設定すると、以下のようにシーケンス内の値を変更せずに維持するカスタムキーワードに設定できる。

type SeqBuilder() =
  member __.For (source, body) =        
    seq { for v in source do yield! body v }
  member __.Yield (item)= 
    seq { yield item }        
  [<CustomOperation("select")>]
  member __.Select (source, [<ProjectionParameter>] f) = 
    Seq.map f source  
  [<CustomOperation("reverse", MaintainsVariableSpace = true)>]
  member __.Reverse (source) =
    List.ofSeq source |> List.rev

let myseq = SeqBuilder() 

myseq { let x = 1
        for i in 1 .. 10 do 
          reverse
          select (x, i + 100) }
|> Seq.iter (printfn "%A")


この他にも、 into の使用をサポートするAllowIntoPatternプロパティや、2つの入力をサポートするIsLikeZipプロパティなど、柔軟な拡張なためのオプションがいくつか用意されている。



サンプル:FizzBuzzBuilder

fizzbuzz { for i in 1..100 do 
	       execute 3 5}
|> Seq.iter (printfn "%A")


上記のようにFizzBuzzを書けるようにする内部DSLを書いてみましょう。

type FizzBuzzBuilder() =
  member __.For (source, body) =        
    seq { for v in source do yield! body v }
  member __.Yield (x) = seq { yield x }        
  [<CustomOperation("select")>]
  member __.Select (source, [<ProjectionParameter>] f) = 
    Seq.map f source  
  [<CustomOperation("execute")>]
  member __.Execute (source, a, b) =
    if a = 0 then invalidArg "fizz" "ゼロだめ"
    if b = 0 then invalidArg "buzz" "ゼロだめ"
    let fzbz x = 
        (x%a,x%b) |> function
        |0,0 -> "FizzBuzz"
        |0,_ -> "Fizz" 
        |_,0 -> "Buzz"
        | _ -> string x
    source |> Seq.map fzbz   

let fizzbuzz = FizzBuzzBuilder() 


サンプル:もっとFizzBuzzBuilder

fizzbuzz { fizz 3
           buzz 5
           execute [1..100]}

|> Seq.iter (printfn "%A")


もうちょっとDSLっぽさを醸し出したいと思います。上記のように記述できるDSLを書いてみましょう。

type FizzBuzzBuilder() =
  [<CustomOperation("fizz")>]
  member __.Fizz (_, x) = x,0
  [<CustomOperation("buzz")>]
  member __.Buzz ((x,_), y) = x,y
  [<CustomOperation("execute")>]
  member __.Execute ((a,b),source) =
    if a = 0 then invalidArg "fizz" "ゼロだめ"
    if b = 0 then invalidArg "buzz" "ゼロだめ"
    let fzbz x = 
        (x%a,x%b) |> function
        |0,0 -> "FizzBuzz"
        |0,_ -> "Fizz" 
        |_,0 -> "Buzz"
        | _ -> string x
    source |> Seq.map fzbz   
  member __.Yield (x) = x 

let fizzbuzz = FizzBuzzBuilder() 


凝ったことは何もしていませんが、これまでのF#2.0ではできない表現です。面白いですね。F#3.0のコンピューテーション式は複雑なDSLを作るには向いているとは言えませんが、あまり複雑ではないちょっとしたDSLが必要になった場合は、検討してみる価値が十分にある手法です。




ちなみに、ビルディング関数および、カスタムキーワードは以下ハードコピーのようにVisual Studio 11 Beta上でもちろんシンタックスハイライトされます。



独自に定義したキーワードもちゃんとハイライトされるなんて。すてき!!!



サンプル:ILBuilder

次はもう少し実用的なサンプル。




MSILerな人は、上記のような感じで記述できるDSLが欲しくなるかもしれません。(というか、そういう人たちはおそらくもう既にお手製のものを作っていることでしょうが。)


open System.Reflection.Emit 

type Stack<'a> = Stack of (ILGenerator -> unit) 
type Completed<'a> = Completed of (ILGenerator -> unit)  

type ILBuilder() =      
  [<CustomOperation("ldc_i4_7")>]
  member __.ldc4_7(x) = 
    Stack(fun ilg -> ilg.Emit(OpCodes.Ldc_I4_7))
  [<CustomOperation("ldc_i4_8")>]
  member __.ldc4_8(Stack f : Stack<int * (int * 'r)>) = 
    Stack(fun ilg -> f ilg; ilg.Emit(OpCodes.Ldc_I4_8))

  [<CustomOperation("ldc_i4_0")>]
  member __.ldc4_0(Stack f : Stack<int * (int * 'r)>) = 
    Stack(fun ilg -> f ilg; ilg.Emit(OpCodes.Ldc_I4_0))

  [<CustomOperation("add")>]
  member __.Add(Stack f : Stack<int * (int * 'r)>) : Stack<int * 'r> = 
    Stack(fun ilg -> f ilg; ilg.Emit(OpCodes.Add))

  [<CustomOperation("mul")>]
  member __.Mul(Stack f : Stack<int * (int * 'r)>) : Stack<int * 'r> = 
    Stack(fun ilg -> f ilg; ilg.Emit(OpCodes.Mul))

  [<CustomOperation("ret")>]
  member __.Ret(Stack f : Stack<int * (int * 'r)>) = 
    Completed(fun ilg -> f ilg; ilg.Emit(OpCodes.Ret))

  member __.Yield x = x
  member __.Run(Completed f : Completed<'a>) : unit -> 'a = 
    let dm = DynamicMethod("", typeof<'a>, [||])
    let g = dm.GetILGenerator() 
    g |> f
    (dm.CreateDelegate(typeof<System.Func<'a>>) :?> System.Func<'a>).Invoke 

let il = ILBuilder() 


かなり適当で且つ大半を割愛しましたが、こんな感じでMSILのDSLとかも作れてしまいます。頑張って真面目に実装したら、MSIL厨歓喜間違いなしです。




RxQueryBuiler

おわりに、非常にクールな内部DSLをご紹介します。
あのReactive ExtensionsをF#でいい感じに記述することができるようになる、RxQueryBuilerです。


When the Reactive Framework meets F# 3.0 - have fun
http://mnajder.blogspot.jp/2011/09/when-reactive-framework-meets-f-30.html



上記記事に掲載されているコードは、若干バージョンが古いもの向けに書かれており、VS11 Betaおよび最新Rx_Experimental-Main(ForkJoinはExperimental版に入ってるので)に対応していないので、少しだけ修正したものを以下に掲載します。具体的な変更箇所は、IObservable<_>.Single()や、IObservable<_>.First()等が、C#およびVBの async/await サポートにより変更となり、代わりに、IObservable<_>.SingleAsync()、IObservable<_>.SingleAsync()を使用するようにしただけです。

open System
open System.Reactive.Linq
open System.Reactive.Concurrency

type RxQueryBuiler() =  
  member this.For (s:IObservable<_>, body : _ -> IObservable<_>) = s.SelectMany(body)
  [<CustomOperation("select", AllowIntoPattern=true)>]
  member this.Select (s:IObservable<_>, [<ProjectionParameter>] selector : _ -> _) = s.Select(selector)
  [<CustomOperation("where", MaintainsVariableSpace=true, AllowIntoPattern=true)>]
  member this.Where (s:IObservable<_>, [<ProjectionParameter>] predicate : _ -> bool ) = s.Where(predicate)
  [<CustomOperation("takeWhile", MaintainsVariableSpace=true, AllowIntoPattern=true)>]
  member this.TakeWhile (s:IObservable<_>, [<ProjectionParameter>] predicate : _ -> bool ) = s.TakeWhile(predicate)
  [<CustomOperation("take", MaintainsVariableSpace=true, AllowIntoPattern=true)>]
  member this.Take (s:IObservable<_>, count) = s.Take(count)
  [<CustomOperation("skipWhile", MaintainsVariableSpace=true, AllowIntoPattern=true)>]
  member this.SkipWhile (s:IObservable<_>, [<ProjectionParameter>] predicate : _ -> bool ) = s.SkipWhile(predicate)
  [<CustomOperation("skip", MaintainsVariableSpace=true, AllowIntoPattern=true)>]
  member this.Skip (s:IObservable<_>, count) = s.Skip(count)
  member this.Zero () = Observable.Empty(Scheduler.CurrentThread)
  member this.Yield (value) = Observable.Return(value)
  [<CustomOperation("count")>]
  member this.Count (s:IObservable<_>) = Observable.Count(s)
  [<CustomOperation("all")>]
  member this.All (s:IObservable<_>, [<ProjectionParameter>] predicate : _ -> bool ) = s.All(new Func<_,bool>(predicate))
  [<CustomOperation("contains")>]
  member this.Contains (s:IObservable<_>, key) = s.Contains(key)
  [<CustomOperation("distinct", MaintainsVariableSpace=true, AllowIntoPattern=true)>]
  member this.Distinct (s:IObservable<_>) = s.Distinct()
  [<CustomOperation("exactlyOne")>]
  member this.ExactlyOne (s:IObservable<_>) = s.SingleAsync()
  [<CustomOperation("exactlyOneOrDefault")>]
  member this.ExactlyOneOrDefault (s:IObservable<_>) = s.SingleOrDefaultAsync()
  [<CustomOperation("find")>]
  member this.Find (s:IObservable<_>, [<ProjectionParameter>] predicate : _ -> bool) = s.FirstAsync(new Func<_,bool>(predicate))
  [<CustomOperation("head")>]
  member this.Head (s:IObservable<_>) = s.FirstAsync()
  [<CustomOperation("headOrDefault")>]
  member this.HeadOrDefault (s:IObservable<_>) = s.FirstOrDefaultAsync()
  [<CustomOperation("last")>]
  member this.Last (s:IObservable<_>) = s.LastAsync()
  [<CustomOperation("lastOrDefault")>]
  member this.LastOrDefault (s:IObservable<_>) = s.LastOrDefaultAsync()
  [<CustomOperation("maxBy")>]
  member this.MaxBy (s:IObservable<'a>,  [<ProjectionParameter>] valueSelector : 'a -> 'b) = s.MaxBy(new Func<'a,'b>(valueSelector))
  [<CustomOperation("minBy")>]
  member this.MinBy (s:IObservable<'a>,  [<ProjectionParameter>] valueSelector : 'a -> 'b) = s.MinBy(new Func<'a,'b>(valueSelector))
  [<CustomOperation("nth")>]
  member this.Nth (s:IObservable<'a>,  index ) = s.ElementAt(index)
  [<CustomOperation("sumBy")>]
  member inline this.SumBy (s:IObservable<_>,[<ProjectionParameter>] valueSelector : _ -> _) = s.Select(valueSelector).Aggregate(Unchecked.defaultof<_>, new Func<_,_,_>( fun a b -> a + b)) 
  [<CustomOperation("groupBy", AllowIntoPattern=true)>]
  member this.GroupBy (s:IObservable<_>,[<ProjectionParameter>] keySelector : _ -> _) = s.GroupBy(new Func<_,_>(keySelector))
  [<CustomOperation("groupValBy", AllowIntoPattern=true)>]
  member this.GroupValBy (s:IObservable<_>,[<ProjectionParameter>] resultSelector : _ -> _,[<ProjectionParameter>] keySelector : _ -> _) = s.GroupBy(new Func<_,_>(keySelector),new Func<_,_>(resultSelector))
  [<CustomOperation("join", IsLikeJoin=true)>]
  member this.Join (s1:IObservable<_>,s2:IObservable<_>, [<ProjectionParameter>] s1KeySelector : _ -> _,[<ProjectionParameter>] s2KeySelector : _ -> _,[<ProjectionParameter>] resultSelector : _ -> _) = s1.Join(s2,new Func<_,_>(s1KeySelector),new Func<_,_>(s2KeySelector),new Func<_,_,_>(resultSelector))
  [<CustomOperation("groupJoin", AllowIntoPattern=true)>]
  member this.GroupJoin (s1:IObservable<_>,s2:IObservable<_>, [<ProjectionParameter>] s1KeySelector : _ -> _,[<ProjectionParameter>] s2KeySelector : _ -> _,[<ProjectionParameter>] resultSelector : _ -> _) = s1.GroupJoin(s2,new Func<_,_>(s1KeySelector),new Func<_,_>(s2KeySelector),new Func<_,_,_>(resultSelector))
  [<CustomOperation("zip", IsLikeZip=true)>]
  member this.Zip (s1:IObservable<_>,s2:IObservable<_>,[<ProjectionParameter>] resultSelector : _ -> _) = s1.Zip(s2,new Func<_,_,_>(resultSelector))
  [<CustomOperation("forkJoin", IsLikeZip=true)>]
  member this.ForkJoin (s1:IObservable<_>,s2:IObservable<_>,[<ProjectionParameter>] resultSelector : _ -> _) = s1.ForkJoin(s2,new Func<_,_,_>(resultSelector))
  [<CustomOperation("iter")>]
  member this.Iter(s:IObservable<_>, [<ProjectionParameter>] selector : _ -> _) = s.Do(selector)

let rxquery = new RxQueryBuiler()


以前、「F#でRxる。よく訓練されたF#ERはコンピューテーション式をつくる。」という記事を書きましたが、F#3.0のカスタムクエリ演算子の登場によって、完全に過去のモノにしてくれました!もういろいろ自由自在ですね。F#でRxなリアクティブプログラマーもこれで勝つる!!!



最後に
大事なことなのでもう一度言っておきますが、F#3.0のコンピューテーション式はもはやモナドだけのための構文ではないのです!!!
F#3.0のコンピューテーション式でイケてる内部DSLを作って、どんどん自慢しちゃいましょう。

*1:コンパイラ作っちゃう変態が多く存在するのもまた事実のようですが

*2:実際にメインで開発に利用する言語