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>] // モナド則１： return x >>= f == f x member test.``01.モナド則1`` () = returnM x >>= f == f x [<Test>] // モナド則２: m >>= return == m member test.``02.モナド則2`` () = let m' = m >>= returnM m' == m [<Test>] // モナド則３: (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 // A「Dがやられたようだな…」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 // // A「Dがやられたようだな…」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以外は嘘つきであるという結果が導きだせましたね！
おまけ：ダイハード３のやつ
なんだか、非決定計算の問題を解くのが面白くなってきちゃったので、せっかくなので限定継続（風）モナドでどんどん解いていきます。まずは、ダイハード３で出題された３ガロンと５ガロンの容器で４ガロンを量るってやつ。いわゆる、水差し問題とゆーやつですね。
これは、わざわざプログラミングで解くまでもないなぞなぞレベルの問いですが、書いてみます。
namespace PitcherProblem module Program = open System open Monad.DCont open Monad.DCont.Amb // ダイハード３の 3ガロンと５ガロンの水差し問題 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# Implementation of BackPropagation Neural Network for Pattern Recognition(LifeGame)
この記事は、F# Advent Calendar 2011の21日目です。
きっかけは、11月19日に札幌で行われた第64回CLR/H勉強会で、愛甲健二さん(@07c00)がお話してくれた「コンピューターに萌えを教えてみたよ」というセッションです。「アダルトサイトの検知」のメカニズムだったり、愛甲さん自身の"萌えの嗜好"をコンピューターに学習させてみるという少しアレゲなテーマでのお話しでしたが、内容はとても真面目で面白かった。見慣れない数式など、その全てを理解することはできませんでしたが、ニューラルネットワークの雰囲気や概要がわかりました。オライリーの「集合知プログラミング」でニューラルネットワークについて少し読んだことがあったり、何となく見聞きしたことはありましたが、基本的な考え方を知ったのはそのときがはじめてです。とても面白くもっと知りたいと思ったので、勉強会の後にモクモクとニューラルネットワークに関する情報を集めて自分なりに勉強してみました。"脳を模してモデル化したアルゴリズムによって、コンピュータに学習能力をもたせる。" なんだか面白かっこいい！じゃないですか。いろいろと調べているうちに、これなら自分にも実装できそう！と思ったので、みんな大好きF#でやってみました。F#の記事というよりも、むしろニューラルネットワーク成分多い目だが、
「大丈夫だ、ゆるふわなので問題ない。」
ニューラルネットワークとは
情報分野におけるニューラルネットワークとは、われわれ人間の脳の神経回路の仕組みを模してモデル化したもので、コンピュータに学習能力を持たせることで、様々な問題を解決しようとするアプローチのひとつで、人工知能の一分野で機械学習というジャンルに属します。もともとニューラルネットワークという研究分野は、人間が自然と行っているパターン認識や経験則を導き出したりする仕組みをモデル化して、ロボットが経験から学習していくことで、正しい反応や行動を獲得していく仕組みを実現することを目的とした側面が強かったようですが、次第に工学寄りにシフトしてきて、「データの中で明らかなものから、明らかではないものを予測する（ことをコンピュータにやらせるための）」技術や理論を指すことがほとんどになってきたようです。近年の自然言語処理や画像のパターン認識、データマイニング、あるいは信用リスク格付け予測など、ビジネス用途での応用分野における成功を要因に、普及と発展が進んでいて現在も広くその研究や応用が進められている。
教師あり学習というアプローチ
機械学習の扱う問題には、大きく分けて教師あり学習 （supervised learning） と、教師なし学習 (unsupervised learning) の２つがある。 単純にその２つに分類することができない、複合的な問題や独自に発展した特殊問題もあるようですが、基本的には、この２つに分類することができる。愛甲さんがお話してくれた、アダルトサイトの検知だったり、「コンピューターに萌えを教えてみたよ」は、ちょうど教師あり学習にあたります。教師あり学習では、入力データ（条件として明らかとなっている情報）が与えられたとき、これに対する出力（答えが明らかではない情報）を正しく予測することが目的です。 もちろん、ただ入力を入れられただけでは、コンピューターは答えとして何を出力したらよいのかわかりません。そこで、訓練データ（あるいは教師データ）と呼ばれる、入出力のペアとしたデータを、あらかじめコンピューター複数与えます。「コレの入力があったら、コレを出力しなさい」というパターンをいくつか与えて機械に学習させます。新しい入力データが来たときに、それに対する正しい出力をするような機械（関数）を作るのが目的です。複雑で広い領域の問題では、すべてのパターンを機械に学習させることは不可能で、当然、あらかじめ学習に用いる訓練データの中には現れない入力データが与えられる場合もあります。そのようなデータに対応するために、与えられた訓練データを一般化して、未知のデータに対処して予測を出力する能力（汎化能力）がなるべく高くなるような、学習アルゴリズムを設計することが、教師あり学習の主要なテーマとなります。ニューラルネットワークは、汎化能力の高い教師あり学習のアプローチのひとつです。
F#でニューラルネットワーク
F#でバックプロパゲーションアルゴリズムを用いた３層パーセプトロンを実装しました。時間がなくて整理しきれなかった部分があり心残りな面もありますが、以下、NNモジュールです。参考になればと思い、普段は書かないような説明的なコメントも多めに書いてみました。
F#
namespace NN open System [<AutoOpen>] module NN = /// 訓練データパターン type Pattern = { Inputs : double list; (* 入力 *) TeachingSignal: double list (* 教師信号 *) } // 層をつくる let createLayer size build = let rec create size acc = if size <= 0 then acc else create ((-) size 1) (acc@[build ()]) create size [] /// シグモイド関数 /// 関数のある点での勾配を求めて誤差Eが少なくなる方向へ結合重みWを変化させていきます。 let sigmoid input bias = /// α(gain)を1.0とするとき標準シグモイド関数と言う let gain : double = 5.0 1.0 / (1.0 + Math.Exp(-gain * (input + bias))) /// ニューロン type Neuron = { mutable bias : double // バイアス mutable error : double // E mutable input : double // 入力 mutable output : double // 出力 learnRate : double // 学習レート weights : Weight list // 重み } /// 出力 member this.Output with get () = if (this.output <> Core.double.MinValue) then this.output else // 判別問題を学習させる場合は階段関数やシグモイド関数を用いる。回帰問題を学習させる場合は線形関数を用いる。 // 今回はシグモイドで sigmoid this.input this.bias and set (v) = this.output <- v // 重み and Weight = { In: Neuron; mutable Value:double } // 層 and Layer = Neuron list /// 活性化 let activate neuron = neuron.input <- 0.0 for w in neuron.weights do neuron.input <- neuron.input + w.Value * w.In.Output /// エラーフィードバック let errorFeedback (neuron:Neuron) (input:Neuron) = neuron.Output * (1.0 - neuron.Output) |> fun derivative -> // より大きな重みで接続された前段のニューロンに対して、局所誤差の責任があると判定する。 let w = neuron.weights |> List.find (fun t -> t.In = input) neuron.error * derivative * w.Value /// 各ニューロンの重みを局所誤差が小さくなるよう調整する。 let adjustWeights (neuron:Neuron) (value:double) = neuron.Output * (1.0 - neuron.Output) |> fun derivative -> neuron.error <- value for i in [0..neuron.weights.Length-1] do // 出力と教師信号が異なれば、出力値を少しだけ教師信号寄りに重みを修正する neuron.weights.[i].Value <- neuron.weights.[i].Value + (neuron.error * neuron.learnRate * derivative * neuron.weights.[i].In.Output) // バイアスの補正 neuron.bias <- neuron.bias + neuron.error * neuron.learnRate * derivative /// 素のニューロンを生成 let createNewron () = { bias = 0.0 error = 0.0 input = 0.0 output = Core.double.MinValue learnRate = 0.5 weights = [] } /// 入力についてランダムな重みを持つニューロンを生成 let createNewron' inputs (rnd:Random) = let createWeights () = inputs |> List.map (fun input -> { In = input; Value = rnd.NextDouble() * 2.0 - 1.0 }) |> List.fold (fun a b -> a@[b]) [] { bias = 0.0 error = 0.0 input = 0.0 output = Core.double.MinValue learnRate = 0.5 weights = createWeights () } /// ネットワーク type Network = { InputSize : int MiddleSize : int OutputSize : int RestartAfter : int TryCount : int Inputs : Layer Middle : Layer Outputs : Layer Patterns : Pattern list } /// 入力層、中間層、出力層のニューロンを生成 let createNeuron inputSize middleSize outputSize = let rnd = new Random() let inputs = createLayer inputSize (fun () -> createNewron ()) let middle = createLayer middleSize (fun () -> createNewron' inputs rnd) let outputs = createLayer outputSize (fun () -> createNewron' middle rnd) inputs, middle, outputs /// ニューラルネットワークの各ニューロンを活性化 let networkActivate (network:Network) (pattern:Pattern) = for i in [0..pattern.Inputs.Length - 1] do network.Inputs.[i].Output <- pattern.Inputs.[i] for neuron in network.Middle do activate neuron for output in network.Outputs do activate output network.Outputs |> List.map (fun output -> output.Output) /// 初期化 let initializeNetwork (network:Network) = let inputs,middle,outputs = createNeuron network.InputSize network.MiddleSize network.OutputSize { network with Inputs = inputs; Middle = middle; Outputs = outputs; TryCount = 0 } /// 訓練データをNetworkに読み込む let loadPatterns (network:Network) (trainingData :(double list * double list) list) = let rec create n acc = if n <= 0 then acc else let inputs,teachingSignal = trainingData.[n] create ((-) n 1) (acc@[{Inputs=inputs; TeachingSignal=teachingSignal}]) { network with Patterns = create (trainingData.Length-1) [] } /// 訓練 let training (network:Network) = /// 重み調整:バックプロパゲーション let adjustWeights (delta:double) = // 個々のニューロンの期待される出力値と倍率(scaling factor)、要求された出力と実際の出力の差を計算する。これを局所誤差と言う。 for output in network.Outputs do adjustWeights output delta for neuron in network.Middle do // そのように判定された前段のニューロンのさらに前段の中間層における隠れニューロン群について同様の処理を行う。 adjustWeights neuron (errorFeedback output neuron) let mutable error = 0.0 for pattern in network.Patterns do // ネットワークの出力とそのサンプルの最適解を比較する。各出力ニューロンについて誤差を計算する。 for i in [0..pattern.TeachingSignal.Length - 1] do let output = (networkActivate network pattern).[i] let delta = pattern.TeachingSignal.[i] - output adjustWeights delta // 二乗誤差でEを求める error <- error + Math.Pow(delta, 2.0) { network with TryCount = network.TryCount + 1}, error /// 三層ネットワークを生成 let createNetwork (inputs:Layer) (middle:Layer) (outputs:Layer) restartAfter = { InputSize = inputs.Length MiddleSize = middle.Length OutputSize = outputs.Length TryCount = 0 RestartAfter = restartAfter Inputs = inputs Middle = middle Outputs = outputs Patterns = [] }
線形分離問題「OR」および「AND」、非線形分離問題 XORを解く
以下、NNモジュールを使って各問題を解くF#
open System open NN open ListExModule [<STAThread>] // 三層分のニューロンを生成 let inputs,middle,outputs = createNeuron 2 3 1 // ニューラルネットワークを構築 let mutable (network:Network,error:float) = createNetwork inputs middle outputs 500 , 1.0 let rec flat = function | [] -> [] | x::_ when x = [] -> [] | x::xs -> x @ flat xs let rec insert v i lst = match i, lst with | 0, xs -> v::xs | i, x::xs -> x::insert v (i - 1) xs | i, [] -> failwith "境界外デス！" let condition = [1..8] let createPattern target ts (source: int list) = let inputs = condition |> List.map (fun i -> if source |> List.exists (fun x -> x = i) then 1.0 else 0.0) |> insert (if target = 1 then 1.0 else 0.0) 4 inputs,[ts] // AND問題 (線形分離可能) let andProblem = [ [0.0; 0.0;], [0.0]; [0.0; 1.0;], [0.0]; [1.0; 0.0;], [0.0]; [1.0; 1.0;], [1.0]; ] // OR問題 (線形分離可能) let orProblem = [ [0.0; 0.0;], [0.0]; [0.0; 1.0;], [1.0]; [1.0; 0.0;], [1.0]; [1.0; 1.0;], [1.0]; ] // XOR問題 (線形分離不可能) let xorProblem = [ [0.0; 0.0;], [0.0]; [0.0; 1.0;], [1.0]; [1.0; 0.0;], [1.0]; [1.0; 1.0;], [0.0]; ] // 訓練データをロード network <- loadPatterns network xorProblem // ここではXORを解く let main () = /// 実行 let run (network:Network) = while true do try Console.Write("Input x, y: ") let values = Console.ReadLine() let line = values.Split(',') let pattern = [0..network.InputSize-1] |> List.map (fun i -> Core.double.Parse(line.[i])) let inputs = List.init(network.InputSize) (fun i-> pattern.[i]) for output in networkActivate network { Inputs=inputs; TeachingSignal = []} do printfn "%d(%f)" <| Convert.ToInt32(output) <| output with | e -> Console.WriteLine(e.Message) // ニューラルネットワークを訓練する while error > 0.1 do let x,y = training network network <- x; error <- y printfn "Try %d\tError %f" x.TryCount y if network.TryCount > network.RestartAfter then network <- initializeNetwork network // 実行 run network main () Console.ReadKey () |> ignore
非線形分離問題も問題なく解けますな。
パターン認識でライフゲーム
バックプロパゲーションアルゴリズムで３層パーセプトロンによって構築したニューラルネットでXOR判定をすることができた。ここで終わってもよかったのですが、せっかくなので欲張って、もう少しだけ複雑な非線形問題のパターン認識もやらせてみました。第64回CLR/H勉強会の、@mentaroさんのセッションの最終デモで「ライフゲーム」が取り上げられていました。勉強会後に、「そういや、ライフゲームのセル生死判定は、判定対象セルとその周囲８つのセルをパターンとして捉えることがきて、セルの生死結果を教師データとするパターンをつくって、多数の訓練データで学習させることで、ニューラルネットワークにライフゲームの生死判定をさせることができるんじゃね？」と思いました。それを実践してみようという。練習にはちょうど良いですね。判定対象セルと周囲の８つのセルを合わせた９つのセルを入力とし、生死の結果を教師データとする訓練データを作成して、ニューラルネットに食わせてシバけばおーけー！
以下、NNモジュールを使って、
F#+XNAで、ニューラルネットのパターン認識でライフゲームなコード
F#
namespace LG open System open Microsoft.Xna.Framework open Microsoft.Xna.Framework.Graphics open Microsoft.Xna.Framework.Input open Microsoft.Xna.Framework.Content open NN open ListExModule [<AutoOpen>] module Assist = // リスト平坦化 let rec flat = function | [] -> [] | x::_ when x = [] -> [] | x::xs -> x @ flat xs // リストへの挿入 let rec insert v i lst = match i, lst with | 0, xs -> v::xs | i, x::xs -> x::insert v (i - 1) xs | i, [] -> failwith "境界外デス！" let condition = [1..8] // パターン生成 let createPattern target ts (source: int list) = let inputs = condition |> List.map (fun i -> if source |> List.exists (fun x -> x = i) then 1.0 else 0.0) |> insert (if target = 1 then 1.0 else 0.0) 4 inputs,[ts] // ライフゲームの教師データ生成 let lifeGameTrainingData = let pattern = [0..8] |> List.map (fun x -> combinations x condition) let survive = List.map (fun x -> x |> createPattern 1 1.0) // 生存 let keep = List.map (fun x -> x |> createPattern 0 0.0) // 維持 let birth = List.map (fun x -> x |> createPattern 0 1.0) // 誕生 let die = List.map (fun x -> x |> createPattern 1 0.0) // 過疎or過密 pattern |> List.mapi (fun i x -> i |> function | 2 -> survive x @ keep x | 3 -> survive x @ birth x | _ -> die x @ keep x) |> flat /// 初期ボード：グライダー銃 let getGliderguns () = [|[|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;1;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;1;0;1;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;1;1;0;0;0;0;0;0;1;1;0;0;0;0;0;0;0;0;0;0;0;0;1;1;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;1;0;0;0;1;0;0;0;0;1;1;0;0;0;0;0;0;0;0;0;0;0;0;1;1;0;0;0;0;0;0|]; [|0;0;1;1;0;0;0;0;0;0;0;0;1;0;0;0;0;0;1;0;0;0;1;1;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;1;1;0;0;0;0;0;0;0;0;1;0;0;0;1;0;1;1;0;0;0;0;1;0;1;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;1;0;0;0;0;0;1;0;0;0;0;0;0;0;1;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;1;0;0;0;1;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;1;1;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]; [|0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0|]|] /// 同じ長さを持つジャグ配列を二次元配列へ変換 let convert (source:int [][]) = (source.[0].GetLength(0),Array.length source) ||> fun row col -> Array2D.create row col 0 |> fun array -> seq { for i in 0..row - 1 do for j in 0..col - 1 do yield i,j } |> Seq.iter (fun (i,j) -> array.[i,j] <- source.[j].[i]) array /// ライフゲーム type LifeGame () as this = inherit Game() // ゲームタイトル, GraphicsDeviceManager, SpriteBatch let gametitle, gmanager, spriteBatch = "LifeGame", new GraphicsDeviceManager(this), lazy new SpriteBatch(this.GraphicsDevice) // 三層パーセプトロンの各ニューロンを生成 -> 入力:9 , 隠れ:17 , 出力:1 let inputs,middle,outputs = createNeuron 9 17 1 // ニューラルネットワークを構築, error状態を取得 let mutable (network:Network,error:float) = createNetwork inputs middle outputs 500 , 1.0 // SpriteFont let font = lazy this.Content.Load<SpriteFont>(@"Content\font\SpriteFont1") // セルのテクスチャ let textureCell = lazy this.Content.Load<Texture2D>(@"Content\hagure") // セルエフェクト用マスクテクスチャ let normalmapTextureCell = lazy this.Content.Load<Texture2D>(@"Content\hagure_alpha") // HLSLエフェクト let normalmapEffect = lazy this.Content.Load<Effect>(@"Content\normalmap") // セルとセルの間の間隔 let borderWidth, borderHeight = 0, 0 // セル描画の開始位置 let boardStartX, boardStartY = 0, 0 // セルのサイズ（テクスチャのサイズによりけり） let cellWidth, cellHeight = 18, 17 // ライフゲームの状態を表すボード let board = getGliderguns() |> convert // ボードのサイズ let width, height = Array2D.length1 board , Array2D.length2 board // ライフゲームの状態の更新制御 let mutable runFlg = true let mutable nowRunFlg = false let mutable previousRunFlg = false // ライフゲームの世代交代インターバル let mutable interval = 10.0 // マウスボタンのリリース状態 let mutable mouseButtonReleased = false // 訓練が終了したか否か let mutable trainingEnd = false // マウスクリック位置の取得 let getPos x y = new Vector2(float32(boardStartX + x * cellWidth + x * borderWidth), float32(boardStartY + y * cellHeight + y * borderHeight)) // セル描画 サークル動作 let moveInCircle (gameTime:GameTime) (speed:float) = let time = gameTime.TotalGameTime.TotalSeconds * speed let x = Math.Sin(time) |> float32 let y = Math.Cos(time) |> float32 new Vector2(x, y) // キー操作 let operateKeys () = let mouseState = Mouse.GetState() let keyboardState = Keyboard.GetState() if mouseState.LeftButton = ButtonState.Pressed && mouseButtonReleased && this.IsActive then // マウスボタン押下中 mouseButtonReleased <- false let mouseStateX, mouseStateY = mouseState.X |> float32, mouseState.Y |> float32 let mousePos = new Vector2(mouseStateX, mouseStateY ) for x in [0..width-1] do for y in [0..height-1] do let pos = getPos x y if pos.X < mousePos.X && pos.X + float32(cellWidth) > mousePos.X && pos.Y < mousePos.Y && pos.Y + float32(cellHeight) > mousePos.Y then // マウスでクリックされたところのセルの生死状態のトグル board.[x, y] <- if board.[x, y] = 0 then 1 else 0 else if mouseState.LeftButton <> ButtonState.Pressed then // マウスボタンをリリース mouseButtonReleased <- true // Pキーによる、PAUSE ON/OFF previousRunFlg <- nowRunFlg nowRunFlg <- keyboardState.IsKeyDown(Keys.P) if nowRunFlg && not previousRunFlg then runFlg <- not runFlg // ライフゲーム状態の更新 let updateState = let updateBoard () = let tmp = Array2D.create width height 0 for x in [0..width-1] do for y in [0..height-1] do let inputs = // x7:左上, x8;上, x9:右上, x4:左, x5:評価対象のセル, x6:右, x1:左下, x2:下, x3:右下 let x7 = if x-1 >= 0 && y-1 >= 0 && board.[x-1, y-1] = 1 then 1.0 else 0.0 let x8 = if y-1 >= 0 && board.[x, y-1] = 1 then 1.0 else 0.0 let x9 = if x+1 < width && y-1 >= 0 && board.[x+1, y-1] = 1 then 1.0 else 0.0 let x4 = if x-1 >= 0 && board.[x-1, y] = 1 then 1.0 else 0.0 let x5 = board.[x, y] |> float let x6 = if x+1 < width && board.[x+1, y] = 1 then 1.0 else 0.0 let x1 = if x-1 > 0 && y+1 < height && board.[x-1, y+1] = 1 then 1.0 else 0.0 let x2 = if y+1 < height && board.[x, y+1] = 1 then 1.0 else 0.0 let x3 = if x+1 < width && y+1 < height && board.[x+1, y+1] = 1 then 1.0 else 0.0 // ライフゲームのパターン [x7;x8;x9; x4;x5;x6; x1;x2;x3] // ニューラルネットワークで判定 let outputs = networkActivate network { Inputs=inputs; TeachingSignal = []} // パターンに対する出力を取得 let output = Convert.ToInt32(outputs.[0]) tmp.[x, y] <- output // ボードに状態を反映 for x in [0..width-1] do for y in [0..height-1] do board.[x, y] <- tmp.[x, y] let settim : double ref = ref 0.0 (fun (gameTime:GameTime) -> if runFlg then let nowMillSeconds = gameTime.TotalGameTime.TotalMilliseconds if !settim + interval < nowMillSeconds then settim := nowMillSeconds // インターバルごとに状態を更新 updateBoard()) let update = let lag = 300. let wait = ref 0. // ニューラルネットワークに訓練データを読み込み network <- loadPatterns network lifeGameTrainingData (fun gameTime -> wait := !wait + 60. if !wait > lag then wait := 0. if not trainingEnd then // 訓練データをロード if error > 0.1 then // ニューラルネットワークを訓練する let nw,err = training network network <- nw; error <- err if network.TryCount > network.RestartAfter then // 乱数の具合が悪かったり、ローカルミニマムにハマったりで訓練がなかなか終わらない場合は、最初から訓練しなおしてみる network <- initializeNetwork network else // 訓練おわりやしたー trainingEnd <- true else // ニューラルネットワークの訓練が終了したら、キー入力を受け付けたりライフゲームを開始 operateKeys () updateState gameTime) do // タイトルを設定 this.Window.Title <- gametitle // ゲームループの間隔を設定 (60FPS) this.TargetElapsedTime <- TimeSpan.FromSeconds(1.0 / 60.) // マウスカーソルを表示 this.IsMouseVisible <- true override this.Initialize() = // ゲームウィンドウのサイズを設定 gmanager.PreferredBackBufferWidth <- this.Width gmanager.PreferredBackBufferHeight <- this.Height base.Initialize () /// ウィンドウの幅 member this.Width with get () = cellWidth * width /// ウィンドウの高さ member this.Height with get () = cellHeight * height /// ライフゲームの状態を更新 override this.Update (gameTime:GameTime) = base.Update gameTime if Keyboard.GetState().IsKeyDown(Keys.Escape) then // Escが押されたらおしまい this.Exit() // ライフゲームクラスの状態を更新 update gameTime /// ライフゲームの状態を描画 override this.Draw (gameTime:GameTime) = base.Draw gameTime // テクスチャーデータのサンプリング方法をClampに設定 gmanager.GraphicsDevice.SamplerStates.[1] <- new SamplerState(AddressU = TextureAddressMode.Clamp, AddressV = TextureAddressMode.Clamp, AddressW = TextureAddressMode.Clamp) // 背景を黒で塗りつぶし gmanager.GraphicsDevice.Clear(Color.Black) // ライフゲームクラスの状態を描画 if not trainingEnd then // ニューラルネットワークの訓練が終わるまでは、訓練の進捗を描画 spriteBatch.Force().Begin() spriteBatch.Force().DrawString(font.Force (), String.Format("NeuralNework Training... Try:{0,3:##0}; Error:{1}", network.TryCount, error), Vector2(0.0f,0.0f), Color.White) spriteBatch.Force().End() else // 訓練終了後は、ライフゲームの状態を描画 for x in [0..width-1] do for y in [0..height-1] do let pos = getPos x y if board.[x, y] = 0 then // 死んでるセルは真っ黒くろ助 spriteBatch.Force().Begin() spriteBatch.Force().Draw(textureCell.Force(), pos, Color.Black) spriteBatch.Force().End() else // 生きてるセルは、セルのテクスチャを描画 // テクスチャの描画に使用するエフェクトの設定 let spinningLight = moveInCircle gameTime 5.0 let time = gameTime.TotalGameTime.TotalSeconds let tiltUpAndDown = 0.5f + float32(Math.Cos(time * 0.75)) * 0.1f let lightDirection = new Vector3(spinningLight * tiltUpAndDown / 2.0f, tiltUpAndDown / 2.0f) lightDirection.Normalize() normalmapEffect.Force().Parameters.["LightDirection"].SetValue(lightDirection) gmanager.GraphicsDevice.Textures.[1] <- normalmapTextureCell.Force() // HLSLのエフェクトを使用して、セルのテクスチャを描画 spriteBatch.Force().Begin(SpriteSortMode.Deferred, BlendState.AlphaBlend, null, null, null, normalmapEffect.Force()) spriteBatch.Force().Draw(textureCell.Force(), pos, Color.White) spriteBatch.Force().End()
ライフゲームの生死判定を学習させるための訓練データは、F#で順列(Permutation)と組み合わせ(Combination)。YOU、Listモナドしちゃいなよ。集合モナドもあるよ。で書いた、
組み合わせ(Combination)を用いて全512パターンを作成しています。
セルを表している「はぐれメタル」の描画には、無駄にHLSL(High Level Shader Language)を使用しています。
HLSL
float3 LightDirection; float3 LightColor = 2.0; float3 AmbientColor = 0.1; sampler TextureSampler : register(s0); sampler NormalSampler : register(s1); float4 main(float4 color : COLOR0, float2 texCoord : TEXCOORD0) : COLOR0 { float4 tex = tex2D(TextureSampler, texCoord); float3 normal = tex2D(NormalSampler, texCoord); float lightAmount = max(dot(normal, LightDirection), 0.2); color.rgb *= AmbientColor + lightAmount * LightColor; return tex * color; } technique Normalmap { pass Pass1 { PixelShader = compile ps_2_0 main(); } }
errorが0.1以下になるまで訓練するようにしているので、ローカルミニマムにハマってしまい、なかなか最後まで学習が完了しない。
早く収束させるには、中間層の隠れニューロンの数を調整したり訓練を甘くして学習レベルを下げるとよい。
この実装では運に左右される。ローカルミニマムに陥る問題を避ける方法はいくつかあるようだが、それはまた別のお話。
SkyDriveに、F#でニューラルネットワークなソースコード一式を置いておきます。
SkyDrive - NN.zip
パケットの送受信量(F#) - ループとbreak
元ネタ
パケットの送受信量 (C#)(F#) - SIN@SAPPOROWORKSの覚書
http://d.hatena.ne.jp/spw0022/20111116/1321437712
F#のwhileにbreakが無いのを知って愕然とした。F#では通常、whileは使用しないのかな？ URL
確かにC#やVB、Javaなどの手続き型言語でのプログラミングに慣れていると、最初はそう思っちゃいますよね。
これぞ「ループでbreak脳の恐怖！」...って、私もその道を通りました。
方法１：再帰を使う
open System open System.Net.NetworkInformation let ar = NetworkInterface.GetAllNetworkInterfaces() |>Seq.map(fun n -> n,n.GetIPv4Statistics()) |>Seq.map(fun (n,s) -> n.Description,s.BytesReceived,s.BytesSent) let rec loop func = match func () with | ConsoleKey.X -> () | _ -> loop func let func () = printfn "%-45s\t%-10s\t%-10s" "Description" "Recv" "Send" printfn "-------------------------------------------------------------------------" ar|>Seq.iter(fun (d,r,s) -> printfn "%-15s\t%10d\t%10d" d r s) printfn "" printfn "何かのキーを押すと更新されます（Xで終了）" Console.ReadKey().Key |> fun key -> Console.Clear() key loop func
方法２：無限シーケンスを使う
open System open System.Net.NetworkInformation let ar = NetworkInterface.GetAllNetworkInterfaces() |>Seq.map(fun n -> n,n.GetIPv4Statistics()) |>Seq.map(fun (n,s) -> n.Description,s.BytesReceived,s.BytesSent) let func () = printfn "%-45s\t%-10s\t%-10s" "Description" "Recv" "Send" printfn "-------------------------------------------------------------------------" ar|>Seq.iter(fun (d,r,s) -> printfn "%-15s\t%10d\t%10d" d r s) printfn "" printfn "何かのキーを押すと更新されます（Xで終了）" let key = Console.ReadKey().Key Console.Clear() key let infiniteSeq = Seq.initInfinite (fun _ -> func()) let run item = if item = ConsoleKey.X then Some(item) else None Seq.pick run infiniteSeq |> ignore
ループでbreakを表現する方法は、他にもいろいろあるでしょう。
■関連リンク
F#で楽々breakとcontinue。継続モナドまじパネぇっす！
http://d.hatena.ne.jp/zecl/20110322/p1
ふと、Seq.tryFindの変な（誰得な）使い方を思いついた。F#でbreakとcontinue再び。
http://d.hatena.ne.jp/zecl/20110822/p1
様々な角度から 物事を見ても、自分を見失わずにありたい。
補足
無限リスト方式が好き。無限リストに対して break キーが押されるまでの Where フィルタ書いて。でも無限リストを書くのに、F# 、構文長過ぎね? Seq.initInfinite とか。
2011-11-16 22:57:46 via web
initInfinite はぜんぜん infinite じゃないのであまり使わなかったり。
2011-11-16 22:59:58 via web
[1...] とかのノリで書けたらいいのになぁ。
2011-11-16 23:01:18 via web
@igeta オーバーフロー gkbr...
2011-11-16 23:08:39 via web to @igeta
let initEternal f = Seq.unfold (fun i -> Some(f i, i+1)) 0
2011-11-16 23:30:39 via web
エターナルアンホールド！！
中二っぽくていいね。
@zecl MSDN の「反復処理は Int32.MaxValue まで続行されます」からしてふつーに打ち切られて終わるのかと思いきや InvalidOperationException の罠ですねわかります。
2011-11-16 23:45:14 via web to @zecl
@igeta ソース見るとそうなってますね。罠としかいいようがない罠！
2011-11-16 23:50:05 via web to @igeta
@zecl Seq.reduce (fun _ x -> x) (Seq.initInfinite id) とかして実証あるのみッ！誤 しかし21億数えるのってけっこう時間かかるのねん。
2011-11-16 23:54:52 via web to @zecl
@igeta さすがに実証はする気にはなれませんでしたw
2011-11-17 00:00:10 via web to @igeta
ということで、Seq.initInfiniteのご利用は計画的に。
ARPテーブルの取得(F#) おまけもあるよ。
元ネタ：ARPテーブルの取得 (C#)(F#) - SIN@SAPPOROWORKSの覚書
http://d.hatena.ne.jp/spw0022/20111108/1320700838
SINさんがF#を書きまくっている今日この頃。F#の街札幌のF#りょくの高まりを感じざるを得ない。
F#らしい書き方かどうかはわかりませんが、SINさんのコードをベースにあまり深く考えずに。
コメント欄にお邪魔するには長いのでこちらで。
ARP(Address Resolution Protocol)テーブルの取得
#nowarn "9" "51" open System open System.Runtime.InteropServices open System.Linq [<DllImport("iphlpapi.dll")>] extern int GetIpNetTable(IntPtr pTcpTable, int *pdwSize, bool bOrder); [<Struct; StructLayout(LayoutKind.Sequential)>] type MIB_IPNETROW = val Index:int val PhysAddrLen:int [<MarshalAs(UnmanagedType.ByValArray, SizeConst = 6)>] val PhysAddr:byte [] val Addr:int val Type:int let ipstr(addr:int)= let b = BitConverter.GetBytes(addr) sprintf "%d.%d.%d.%d" b.[0] b.[1] b.[2] b.[3] let macstr(m:byte []) = sprintf "%02x-%02x-%02x-%02x-%02x-%02x" m.[0] m.[1] m.[2] m.[3] m.[4] m.[5] let typeStr = ["";"その他";"無効";"動的";"静的"] //取得部分 let ar = let mutable size = 0 GetIpNetTable(IntPtr.Zero, &&size, true) |> ignore let p = Marshal.AllocHGlobal(size) if GetIpNetTable(p, &&size, true) = 0 then let end' = Marshal.ReadInt32(p) - 1 let result = let step = Marshal.SizeOf(typeof<MIB_IPNETROW>) let getPtr = let ptr' = ref (IntPtr.Add(p, 4)) (fun num -> if num=0 then !ptr' else ptr':=IntPtr.Add(!ptr',step); !ptr') [0..end'] |> List.map (fun x -> getPtr x) |> List.map (fun ptr -> Marshal.PtrToStructure(ptr, typeof<MIB_IPNETROW>) :?> MIB_IPNETROW) Marshal.FreeHGlobal(p) result else [] //出力部分 printfn "インデックス\tインターネット アドレス\t物理アドレス\t種類" ar |> List.toSeq |> Seq.groupBy (fun n -> n.Index) |> Seq.iter (fun (i,ms) -> printfn "\nインターフェース:0x%x\n インターネット アドレス\t物理アドレス\t種類" i ms |> Seq.iter (fun m -> printfn " %-15s\t%s\t%s" <| ipstr(m.Addr) <| macstr(m.PhysAddr) <| typeStr.[m.Type])) printfn "何かのキーを押してください。" Console.ReadKey() |> ignore
■主な変更点とかモロモロ
- ワーニングの波線が残り続けるのは、精神衛生上アレなので #nowarn で非表示に。
- 取得部分をひとまとめの関数に。
- なるべく、みゅーたぶり(mutableを使い)たくはないので、そのあたりをいじる。
- 「for 〜 in 〜 do 〜」を利用することは、決してわるいことではありません。が、F#ではSeqモジュールを利用してLINQのノリで書ける。
- 元ネタ「ar.Where(fun (x:MIB_IPNETROW) -> x.Index=i.Key)」で再度絞り込みする必要はなく、arのGroupByした結果をそのまま利用して結果を出力する。
- 前方パイプライン演算子には負けますが、後方パイプライン演算子もなかなかかわいいです。
- ふつうのF#erなので、奇をてらったへんたいコードは書きません。
おまけ
趣旨からはだいぶズレますが、コマンドラインからコマンドを実行して取得した値をそのまま書き出すズルしてみたり:p
open System let filename = Environment.GetEnvironmentVariable("ComSpec") let arguments = @"/c arp -a" let psi = new Diagnostics.ProcessStartInfo(filename, arguments, CreateNoWindow = true, UseShellExecute = false, RedirectStandardInput = false, RedirectStandardOutput = true) let p = Diagnostics.Process.Start(psi) p.WaitForExit() let results = p.StandardOutput.ReadToEnd() printfn "%s" results Console.ReadKey () |> ignore
これはひどいｗ
とことんF#よぷよ！ 第 63 回 CLR/H 勉強会で、F#とXNAを題材に発表します。
F# + XNAでとことんF#よぷよ！してみました
「ダークソウル」で心が折れそうな日々を送っている今日このごろですが、みなさんはいかがお過ごしでしょうか。
F# + XNAで「とことんぷよぷよ」っぽいものを実装してみました（はじめてのXNAゲームプログラミング）。
ただし、意図的、あるいは意図せずに元ネタのそれの仕様とは異なる場合があります。
動画の終盤、PAUSEをしてチート機能を使うことで１９連鎖のデモをしています。
第 63 回 CLR/H 勉強会で、F#とXNAを題材にお話します。
日時 ： 2011/10/15 (土) 13:30〜18:00（開場 13:00）
場所 ： マイクロソフト北海道支店 セミナールーム （札幌市中央区北 5 条西 2 丁目 5 JR タワーオフィスプラザさっぽろ 20F）
http://www.microsoft.com/ja-jp/mscorp/branch/hokkaido.aspx
参加費：500 円（会場費やお菓子代に使用させて頂きます）
【タイトル】
とことんF#よぷよ！ - F# + XNAによるゲームプログラミング入門 -
【概要】
みんな大好き、落ち物パズルゲーム「ぷよぷよ」は今年で 20 周年を迎えました。
ぷよぷよ風落ち物パズルゲームの作り方と、関数型パラダイムを中心としたマルチパラダイム言語 F# による
XNA でのゲーム開発の基本についてお話します。
「ぷよぷよ風落ちゲーを 500 行程度で実装できる。そう、F# + XNA ならね！」
【スピーカー】
わたし
CLR/H 公式サイト
http://clr-h.jp/
また、マイクロソフトのエバンジェリストで、著作に「The root of .NET Framework」や「実践 F# 関数型プログラミング入門」などがある
荒井省三さんが、「DLR + ASync + アルファ」というタイトルで濃いセッションをしてくださいます。ぜひお越しください。
事前に「とことんF＃よぷよ！」のコードを晒してみる
ということで、F#でXNAなコードを勉強会前に晒してしまう大盤振る舞い（！？）
コードは決してうつくしくはありませんが、興味のある方はごらんください。
PuyoPuyo.fs
namespace PuyoPuyoLibrary open System type PuyoColors = | n = 0x00 | r = 0x01 | y = 0x02 | p = 0x03 | g = 0x04 | b = 0x05 type Union = | None = 0b0000 | Top = 0b0001 | Left = 0b0010 | Bottom = 0b0100 | Right = 0b1000 type puyoObj = { position : int * int; pattern : PuyoColors[][]; color1: PuyoColors; color2: PuyoColors; hidden: bool; upside : bool} type PuyoState = { pw : int; ph : int; width : int; height : int gameover : bool; pause : bool ;cheat : bool totalScore : decimal; highScore : decimal; maxLevel : int scoreBase : int; magnifyingPower : int rensa : int; union : int; colors : int; erased : int current : puyoObj; next : puyoObj array field : PuyoColors[,]; checkField : bool[,] falling : bool; allclear : bool etarget : (int * int * PuyoColors) list} module PuyoPuyo = let patterns x y = [| [| enum 0; x; enum 0; |] [| enum 0; y; enum 0; |] [| enum 0; enum 0; enum 0; |] |] let none : PuyoColors [][] = [| [| |] |] let clearCheckField ps = { ps with checkField = Array2D.create ps.width ps.height false } let getLevel erased = erased / 40 |> fun x -> if x >= 999 then 999 else x + 1 let create erased = let rand = new Random(System.DateTime.Now.Millisecond) let create' = fun s e -> enum (rand.Next(s, e)), enum (rand.Next(s, e)) fun () -> (if getLevel erased < 3 then (1,4) ||> create' elif getLevel erased < 5 then (1,5) ||> create' else (1,6) ||> create') ||> fun x y -> { position = (1, 0); pattern = patterns x y; color1 = x; color2 = y; hidden = false; upside = true } let getPuyoObj = let queue = new System.Collections.Generic.Queue<puyoObj>() fun erased -> queue.Count |> function | 0 -> seq {1..3} |> Seq.iter (fun x -> queue.Enqueue ( () |> create erased)) queue.Dequeue(),queue.ToArray() | _ -> queue.Enqueue(() |> create erased) queue.Dequeue(),queue.ToArray() let convert (source : PuyoColors [][]) = (Array.length source, source.GetLength(0)) ||> fun row col -> Array2D.create row col PuyoColors.n |> fun array -> if source = none then array else seq { for i in 0..row - 1 do for j in 0..col - 1 do yield i,j } |> Seq.iter (fun (i,j) -> array.[j,i] <- source.[i].[j]) array type Direction = | Right | Left | Down let move ps direction = ps.current.position ||> fun x y -> direction |> function | Right -> { ps.current with position = x + 1, y } | Left -> { ps.current with position = x - 1, y } | Down -> { ps.current with position = x , y + 1 } let descend ps = ps.current.position ||> fun x y -> if y + 1 < ps.height then { ps.current with position = x, y + 1 } else ps.current let rotate puyo action = convert puyo.pattern |> fun pattern -> let len = Array2D.length1 pattern seq { for i in 0..len - 1 do for j in 0..len - 1 do yield i,j,len,pattern} |> Seq.iter action puyo let avoidance ps exchange (c1,c2) = let (|Insert|_|) c1 c2 ps = ps.current.position ||> fun x y -> let judge c f g= if (c <> PuyoColors.n && (x < 0 || (x >= 0 && (ps.field.[x,y] <> PuyoColors.n || ps.field.[x,y+1] <> PuyoColors.n)))) && (c <> PuyoColors.n && (x+2 > ps.width - 1 || (x+2 <= ps.width - 1 && (ps.field.[x+2,y] <> PuyoColors.n || ps.field.[x+2,y+1] <> PuyoColors.n)))) then f() else g() judge c1 (fun () -> Some ps.current) (fun () -> judge c2 (fun () -> Some ps.current) (fun () -> None)) let (|CollideLeft|_|) c1 c2 ps = ps.current.position ||> fun x y -> if (c1 <> PuyoColors.n || c2 <> PuyoColors.n) && (x < 0 || (x >= 0 && (ps.field.[x,y] <> PuyoColors.n || ps.field.[x,y+1] <> PuyoColors.n ))) then Some ps.current else None let (|CollideRight|_|) c1 c2 ps = ps.current.position ||> fun x y -> if (c1 <> PuyoColors.n || c2 <> PuyoColors.n) && (x+2 > ps.width - 1 || (x+2 <= ps.width - 1 && (ps.field.[x+2,y] <> PuyoColors.n || ps.field.[x+2,y+1] <> PuyoColors.n))) then Some ps.current else None ps |> function | Insert c1 c2 puyo -> puyo | CollideLeft c1 c2 puyo -> move ps Right |> rotate <| exchange | CollideRight c1 c2 puyo -> move ps Left |> rotate <| exchange | _ -> ps.current |> rotate <| exchange let target ps = ps.current.pattern.[2].[1], ps.current.pattern.[0].[1] let rotateR ps = if ps.current.pattern = none then ps.current else (fun (i,j,len,pattern:PuyoColors[,]) -> ps.current.pattern.[i].[j] <- pattern.[i,len - 1 - j]) |> avoidance ps <| target ps let rotateL ps = if ps.current.pattern = none then ps.current else (fun (i,j,len,pattern:PuyoColors[,]) -> ps.current.pattern.[j].[i] <- pattern.[len - 1 - j,i]) |> avoidance ps <| target ps let createState pw ph width height erased = let current,next = getPuyoObj erased { pw = pw; ph = ph; width = width; height = height; gameover = false; pause = false; cheat = false; totalScore = decimal 0; highScore = decimal 0; maxLevel = 0; scoreBase = 0; magnifyingPower = 0; rensa = 0; union = 0; colors = 0; erased = 0; current = current; next = next; field = Array2D.create width height PuyoColors.n checkField = Array2D.create width height false; falling = false; allclear = false; etarget = List.empty } let nextPuyo ps = if not ps.cheat then getPuyoObj ps.erased ||> fun current next -> {ps with current= current; next = next} else { ps with current = { position = (1, 0); pattern = patterns PuyoColors.p PuyoColors.y; color1 = PuyoColors.p; color2 = PuyoColors.y; hidden = false; upside = true }; next = ps.next } let reset ps = nextPuyo { ps with erased = 0 } |> fun ps -> nextPuyo ps |> fun ps -> nextPuyo ps |> fun ps -> { ps with field = Array2D.create ps.width ps.height PuyoColors.n; checkField = Array2D.create ps.width ps.height false; etarget = List.empty gameover = false; pause = false; cheat = false; totalScore = decimal 0; maxLevel = ps.maxLevel; highScore = ps.highScore; scoreBase = 0; magnifyingPower = 0; rensa = 0; union = 0; colors = 0; allclear = false } let cheat ps = Array2D.create ps.width ps.height PuyoColors.n |> fun newfield -> let dic = dict[0,[0;0;0;2;1;1];1,[1;2;0;3;2;3];2,[3;2;3;2;1;1];3,[1;2;3;2;1;3];4,[2;3;2;1;2;3];5,[3;2;1;2;1;3];6,[2;3;2;1;2;1];7,[2;3;2;1;2;1];8,[2;1;1;3;1;3];9,[1;2;3;2;3;3];10,[3;1;2;3;2;1];11,[3;1;2;3;2;1];12,[3;1;2;3;2;1]] for y in 0..ps.height - 1 do dic.[y] |> List.iteri (fun x c -> newfield.[x, y] <- enum c) nextPuyo { ps with field = newfield; cheat = true } let detectCollision puyo field = let result = ref false puyo.pattern |> convert |> Array2D.iteri (fun i j c -> c |> function | PuyoColors.n -> () | _ -> puyo.position ||> fun x y -> (x + i,y + j) ||> fun xi yj -> if xi < 0 || xi >= Array2D.length1 field || yj < 0 || yj >= Array2D.length2 field || field.[xi, yj] <> PuyoColors.n then result := true); !result let getAllclearScore ps = if ps.field = Array2D.create ps.width ps.height PuyoColors.n |> not then decimal 0 else decimal 3600 + decimal (getLevel ps.erased * 5) let getScore ps = let rensaBonus n = dict [1,0;2,8;3,16;4,32;5,64;6,96;7,128;8,160;9,192;10,224;11,256;12,288;13,320;14,352;15,388;16,416;17,448;18,480;19,512] |> fun dic -> if n > 19 then dic.[19] else dic.[n] let unitBounus n = dict [4,0;5,2;6,3;7,4;8,5;9,6;10,7;] |> fun dic -> if n > 10 then 10 else dic.[n] let colursBounus n = dict [0,0;1,0;2,3;3,6;4,12;5,24] |> fun dic -> dic.[n] let a,b,c,d = ps.union * 10,rensaBonus ps.rensa,unitBounus ps.union,colursBounus ps.colors // 基本得点,連鎖ボーナス,連結ボーナス,複色ボーナス b + c + d |> fun x -> if x = 0 then a,1 else a,x let fixed' ps = ps.current.pattern |> convert |> fun c -> seq { for i in 0..Array2D.length1 c - 1 do for j in 0..Array2D.length2 c - 1 do c.[i,j] |> function | PuyoColors.n -> () | _ -> ps.current.position ||> fun x y -> ps.field.[x + i, y + j] <- ps.current.pattern.[j].[i] } |> Seq.iter id { ps with current = {ps.current with hidden = true }; falling = true } let fall ps = seq { for x in 0..ps.width-1 do for y in [ps.height-1 .. -1 .. 0] do if ps.field.[x,y] = PuyoColors.n then for z in (y-1) .. -1 .. 0 do if ps.field.[x,z] > PuyoColors.n then ps.field.[x,z+1] <- ps.field.[x,z] ps.field.[x,z] <- PuyoColors.n yield z } |> Seq.length let erase ps = let erase' x y ps = if ps.field.[x,y] = PuyoColors.n then None else let result, list = ref 1, ref [x,y] let rec search x y result = ps.checkField.[x,y] <- true let search' x y retsult f g predicate = if predicate (f x) (g y) ps && ps.checkField.[f x, g y] <> true && ps.field.[f x, g y] = ps.field.[x,y] then result := !result + 1 list := !list@[f x, g y] search (f x) (g y) result search' x y result (fun x -> x+1) id (fun x y ps -> x < ps.width) search' x y result id (fun y -> y+1) (fun x y ps -> y < ps.height) search' x y result (fun x -> x-1) id (fun x y ps -> x > 0) search' x y result id (fun y -> y-1) (fun x y ps -> y > 0) search x y result if !result >= 4 then List.map (fun (x,y) -> x,y,ps.field.[x,y] )!list |> Some else None seq { for x in 0..ps.width-1 do for y in ps.height-1 .. -1 .. 0 do let ecount = erase' x y (clearCheckField ps) |> function |Some x -> x | _ -> [] yield! ecount } |> Seq.distinct |> Seq.toList |> fun etarget -> let colors = List.map (fun (x,y,_) -> ps.field.[x,y]) etarget |> Seq.distinct |> Seq.toList etarget,List.length etarget, List.length colors, { ps with current = { ps.current with pattern = none } } let getUnion ps x y = if x < 0 || x > ps.width - 1 || y > ps.height - 1 || ps.field.[x,y] = PuyoColors.n then Union.None else let rise ps x y = [y..(ps.height-1)] |> List.exists (fun y -> ps.field.[x,y] = PuyoColors.n) let lrunion n b f add = if b || (ps.field.[f x,y] = ps.field.[x,y] && (y = ps.height - 1 || (y < ps.height - 1 && (rise ps x y |> not && rise ps (f x) y |> not)) || (y < ps.height - 1 && (rise ps x y && rise ps (f x) y )))) |> not then n else add n let left n = lrunion n (x = 0) (fun x -> x - 1) ((+) Union.Left) let right n = lrunion n (x >= ps.width - 1) ((+) 1) ((+) Union.Right) let tbunion n f g c = if f || ps.field.[x,g y] = ps.field.[x,y] |> not then n else n + c let top n = tbunion n (y = 0) (fun y -> y - 1) Union.Top let bottom n = tbunion n (y >= ps.height - 1) (fun y -> y + 1) Union.Bottom Union.None |> (top >> left >> right >> bottom)
PuyoGame.fs
namespace FSharpyopuyo open System open System.Runtime.Serialization open Microsoft.Xna.Framework open Microsoft.Xna.Framework.Audio open Microsoft.Xna.Framework.Graphics open Microsoft.Xna.Framework.Input open Microsoft.Xna.Framework.Storage open PuyoPuyoLibrary [<DataContract>] type SaveGameData = { [<field:DataMember(Name="MaxLevel")>] MaxLevel : int; [<field:DataMember(Name="HighScore")>] HighScore : decimal } type PuyoGame () as this = inherit Game() let gametitle, gmanager, sprite = "とことんF#よぷよ！", new GraphicsDeviceManager(this), lazy new SpriteBatch(this.GraphicsDevice) let mutable ps = PuyoPuyo.createState 32 32 6 13 0 let slowTimelag,fastTimelag, fps = 350.,230.,60. let backgroundTexture,puyoTexture,blinkTexture,gameoverTexture,allclearTexture,carbancleTexture,suketoudaraTexture = ["background";"puyopuyo";"blink";"batanQ";"allclear";"carbuncle";"suketoudara"] |> List.map (fun name -> lazy this.Content.Load<Texture2D>(@"Content\image\" + name)) |> function | a::b::c::d::e::f::g::[] -> a,b,c,d,e,f,g | _ -> invalidArg "tlist" "リストの長さが違うよ。" let font = lazy this.Content.Load<SpriteFont>(@"Content\font\SpriteFont1") let gameSe = ["move";"rotate";"drop";"batanQ";"allclear";"pafu";] |> List.map (fun name -> this.Content.Load<SoundEffect>(@"Content\sound\" + name).CreateInstance() |> fun x -> x.Volume <- 0.3f; lazy x) let chainSe = [1..19] |> List.map (fun i -> this.Content.Load<SoundEffect>(@"Content\sound\chain" + if i > 7 then string 7 else string i).CreateInstance() |> fun x -> x.Volume <- 0.3f; lazy x) let chainVoice = [1..19] |> List.map (fun i -> this.Content.Load<SoundEffect>(@"Content\sound\chainvoice" + if i > 5 then string 5 else string i).CreateInstance() |> fun x -> x.Volume <- 0.3f; lazy x) let bgm = (this.Content.Load<SoundEffect>(@"Content\sound\MorningOfPuyoPuyo").CreateInstance() |> fun x -> x.Volume <- 0.2f; x.IsLooped <- true; lazy x) let soundPlay (se:Lazy<SoundEffectInstance>) = se.Force().Play() let checkPauseKey = let keyWait, pauseKeyDown, pauseTimelag = ref 0., ref false, 700. (fun () -> if not ps.gameover then keyWait := !keyWait + fps if ps.pause && !keyWait > pauseTimelag && Keyboard.GetState().IsKeyDown(Keys.F12) then ps <- PuyoPuyo.cheat ps; if !keyWait > pauseTimelag && Keyboard.GetState().IsKeyDown(Keys.P) && !pauseKeyDown then gameSe.[5] |> soundPlay; bgm |> soundPlay; ps <- { ps with pause = false }; pauseKeyDown := false elif !keyWait > pauseTimelag && Keyboard.GetState().IsKeyDown(Keys.P) && not !pauseKeyDown then gameSe.[5] |> soundPlay; bgm.Force().Stop(); ps <- { ps with pause = true }; pauseKeyDown := true if !keyWait > pauseTimelag then keyWait := 0.) let operateKeys = let keyWait = ref 0. (fun () -> keyWait := !keyWait + fps let operateKey key = if not ps.gameover then key |> function | Keys.Z | Keys.Space | Keys.NumPad8 when !keyWait > slowTimelag -> gameSe.[1] |> soundPlay; Some (PuyoPuyo.rotateL ps) | Keys.X | Keys.Up | Keys.NumPad5 when !keyWait > slowTimelag -> gameSe.[1] |> soundPlay; Some (PuyoPuyo.rotateR ps) | Keys.Right | Keys.NumPad6 when !keyWait > slowTimelag -> gameSe.[0] |> soundPlay; Some (PuyoPuyo.move ps PuyoPuyo.Right) | Keys.Left | Keys.NumPad4 when !keyWait > slowTimelag -> gameSe.[0] |> soundPlay; Some (PuyoPuyo.move ps PuyoPuyo.Left) | Keys.Down | Keys.NumPad2 when !keyWait > fastTimelag -> if ps.current.hidden |> not then ps <- { ps with totalScore = (+) ps.totalScore <| decimal 1 } Some (PuyoPuyo.move ps PuyoPuyo.Down) | Keys.Escape -> this.Exit(); None | _ -> None else key |> function | Keys.Enter -> ps <- PuyoPuyo.reset ps; bgm |> soundPlay; None | Keys.Escape -> this.Exit(); None | _ -> None |> function | Some x -> if not (PuyoPuyo.detectCollision x ps.field) then ps <- { ps with current = x } | None -> () let resetWait () = if !keyWait > slowTimelag then keyWait := 0. Keyboard.GetState().GetPressedKeys() |> Array.toList |> List.sort |> List.rev |> function | [x] -> operateKey x; resetWait () | [x;y] -> operateKey x; operateKey y; resetWait () | [x;y;z] | x::y::z::_ -> operateKey x; operateKey y; operateKey z; resetWait () | _ -> () ) let blink = let blinkWait, blink = ref 0., ref false fun () -> if ps.pause then !blink else blinkWait := !blinkWait + fps if !blinkWait > 5. * fps then blink := not !blink; blinkWait := 0. !blink let saveFilename = "puyosys.sav" let saveStorage (device:StorageDevice) (level:int) score = let result = device.BeginOpenContainer(gametitle, null, null) if result.AsyncWaitHandle.WaitOne() then use container = device.EndOpenContainer(result) result.AsyncWaitHandle.Close() if container <> null then if (container.FileExists(saveFilename)) then container.DeleteFile(saveFilename) use stream = container.CreateFile(saveFilename) let serializer = DataContractSerializer(typeof<SaveGameData>) serializer.WriteObject(stream , { MaxLevel = level; HighScore = score }) let loadStorage (device:StorageDevice) = let result = device.BeginOpenContainer(gametitle, null, null) let level,highscore = ref 1, decimal 0 |> ref if result.AsyncWaitHandle.WaitOne() then use container = device.EndOpenContainer(result) result.AsyncWaitHandle.Close() if container <> null && container.FileExists(saveFilename) then use stream = container.OpenFile(saveFilename, System.IO.FileMode.Open ) let serializer = DataContractSerializer(typeof<SaveGameData>) let data = serializer.ReadObject(stream) :?> SaveGameData level := data.MaxLevel; highscore := data.HighScore !level, !highscore let drawPuyo (c:PuyoColors, x, y, ((i, j) as point)) (location:Vector2) rect hw = let fx,fy = float32 (x+i), float32 (y+j) let lx,ly = float32 location.X, float32 location.Y let draw f = sprite.Force().Draw(puyoTexture.Force(), Vector2(32.f * fx + lx,32.f * fy + ly |> f), Nullable rect, Color.White) if point = (1,1) then let texture = if blink () then blinkTexture.Force() else puyoTexture.Force() sprite.Force().Draw(texture, Vector2(32.f * fx + lx,32.f * fy + ly |> f), Nullable rect, Color.White) c |> function | PuyoColors.n -> () | _ -> if hw && ps.current.upside then (fun x -> x - 16.f) |> draw else draw id let uncoupling c adjustx = Rectangle(0, ps.ph * (int c - 1), ps.pw / adjustx, ps.ph) let drawText (msg:string) (v:Vector2) c = sprite.Force() |> function | x -> font.Force() |> fun font -> [font, msg, Vector2(v.X+3.f,v.Y+3.f), Color.Black; font, msg, v, c ] |> List.iter (fun (font, msg, v, c) -> x.DrawString(font, msg, v, c)) let drawLiteral () = ["NEXT",Vector2(240.f, 34.f),Color.MediumSpringGreen; "LEVEL",Vector2(240.f, 322.f),Color.MediumSpringGreen; "SC.",Vector2(32.f, 420.f),Color.HotPink; "HSC.",Vector2(32.f, 2.f),Color.Orange; "MLV.",Vector2(230.f, 2.f),Color.Orange] |> List.iter (fun (s,v,c) -> drawText s v c) let drawScoreAndLevel () = seq { yield ((PuyoPuyo.getLevel ps.erased |> string).PadLeft(3,'0')), Vector2(255.f, 356.f), Color.HotPink if ps.totalScore < ps.highScore then yield string ps.highScore |> fun s -> s, Vector2(224.f - font.Force().MeasureString(s).X, 2.f), Color.Orange else yield string ps.totalScore |> fun s -> s, Vector2(224.f - font.Force().MeasureString(s).X, 2.f) , Color.Orange if ps.etarget = List.empty then yield string ps.totalScore |> fun s -> s, Vector2(224.f - font.Force().MeasureString(s).X, 420.f), Color.HotPink else yield string ps.scoreBase + "×" + (string ps.magnifyingPower).PadLeft(4,' ') |> fun s -> s, Vector2(224.f - font.Force().MeasureString(s).X, 420.f), Color.SkyBlue if (PuyoPuyo.getLevel ps.erased) < ps.maxLevel then yield (string ps.maxLevel).PadLeft(3,'0') , Vector2(280.f , 2.f), Color.Orange else yield (PuyoPuyo.getLevel ps.erased |> string).PadLeft(3,'0') , Vector2(280.f , 2.f), Color.Orange } |> Seq.iter (fun (s,v,c) -> drawText s v c) let drawField = let gameoverWait = ref 0. (fun location () -> let unit ps x y (c:PuyoColors) adjustx = PuyoPuyo.getUnion ps x y |> fun r -> Convert.ToInt32(r |> int |> string) |> fun x -> Rectangle(ps.pw * x,ps.ph * (int c - 1), ps.pw / adjustx, ps.ph) ps.field |> Array2D.iteri (fun i j c -> if j > 0 then drawPuyo(c, i, j, (0, 0)) location (unit ps i j c 1) false) if ps.gameover then sprite.Force().Draw(gameoverTexture.Force(), Vector2(50.f,400.f - float32 !gameoverWait / 40.f), Color(255, 255, 255, 128)) if !gameoverWait <= 12000. then bgm.Force().Stop() gameSe.[3] |> soundPlay gameoverWait := !gameoverWait + fps * 3. else ["つづける:Enter",10.f;"やめる:Esc",50.f] |> List.iter (fun (msg,y) -> drawText msg <| Vector2(45.f, 160.f + y) <| Color.Gold) else gameoverWait := 0. if ps.current.hidden |> not then ps.current.position ||> fun x y -> (ps.current.pattern) |> PuyoPuyoLibrary.PuyoPuyo.convert |> Array2D.iteri (fun i j c -> if y + j > 0 then drawPuyo(c, x , y, (i, j)) location (uncoupling c 1) true) sprite.Force().Draw(backgroundTexture.Force(), Vector2(0.f,0.f),Nullable(Rectangle(0,0,256,32)), Color.White)) <| Vector2(32.f, 0.f) let drawErase = let animeWait = ref 0. (fun f (location:Vector2) () -> if ps.etarget <> List.empty then animeWait := !animeWait + fps let draw union = List.iter (fun (x,y,c) -> if y > 0 then drawPuyo(c, x, y, (0, 0)) location (Rectangle(ps.pw * union ,ps.ph * (int c - 1), ps.pw, ps.ph)) false) ps.etarget if !animeWait < 780. then draw 16 elif !animeWait < 1560. then draw 17 else animeWait := 0.; f()) <| (fun () -> ps <- { ps with etarget = List.empty }) <| Vector2(32.f, 0.f) let drawAnimation (texture:Lazy<Texture2D>) width hight max vector = let animeWait, counter = ref 0., ref 0 (fun (location:Vector2) () -> animeWait := !animeWait + fps if !animeWait > 780. - (30. * float (PuyoPuyo.getLevel ps.erased + 1)) then animeWait := 0.; if not ps.pause then incr counter sprite.Force().Draw(texture.Force(), location, Nullable (Rectangle(width * !counter,0,width,hight)), Color.White) if !counter = max then counter := 0) <| vector let drawCarbancle = drawAnimation <| carbancleTexture <| 25 <| 25 <| 37 <| Vector2(260.f,388.f) let drawSukesoudara = drawAnimation <| suketoudaraTexture <| 72 <| 54 <| 10 <| Vector2(236.f,228.f) let drawNext () = let drawPuyo' pattern location adjustx = pattern |> PuyoPuyoLibrary.PuyoPuyo.convert |> Array2D.iteri (fun i j c -> drawPuyo (c, 1, j, (0, 0)) location (uncoupling c adjustx) false) Vector2(224.f, 96.f) |> fun location -> [ps.next.[0].pattern, location, 1; ps.next.[1].pattern, (Vector2(location.X + 32.f, location.Y + 32.f)), 2] |> List.iter (fun (p,v,a) -> drawPuyo' p v a) let drawAllClear () = if ps.allclear then sprite.Force().Draw(allclearTexture.Force(), Vector2(45.f,50.f), Color.White) let drawPause () = if ps.pause then drawText "PAUSE" <| Vector2(96.f,150.f) <| Color.Gold let drawRensa = let rensaWait, rensaCount = ref 0., ref 0 (fun () -> if ps.pause |> not then rensaWait := !rensaWait + fps * 1.5 if ps.rensa > 0 && !rensaWait < 25. * fps then (3,7) ||> fun x y -> drawText (string ps.rensa + "れんさ") <| Vector2(32.f * float32 x, 32.f * float32 y - float32(!rensaWait / 40.)) <| Color.HotPink if ps.rensa <> !rensaCount && !rensaWait > 50. * fps then rensaCount := ps.rensa; rensaWait := 0. ) let save () = let save maxLevel highScore = let result = StorageDevice.BeginShowSelector(PlayerIndex.One, null, null) let device = StorageDevice.EndShowSelector(result) saveStorage device maxLevel highScore ps <- { ps with maxLevel = maxLevel; highScore = highScore } let maxlevelAndHighScore () = if PuyoPuyo.getLevel ps.erased > ps.maxLevel then PuyoPuyo.getLevel ps.erased else ps.maxLevel , if ps.totalScore > ps.highScore then ps.totalScore else ps.highScore if PuyoPuyo.getLevel ps.erased > ps.maxLevel || ps.totalScore > ps.highScore then maxlevelAndHighScore () ||> fun maxLevel highScore -> save maxLevel highScore let update = let updateWait, updateTimelag = ref 0., ref (72. * fps + (15. * float (PuyoPuyo.getLevel ps.erased))) let chain = (fun cont -> if ps.etarget = List.empty && PuyoPuyo.fall ps > 0 then ps <- { ps with falling = true } updateTimelag := 24. * fps + (15. * float (PuyoPuyo.getLevel ps.erased + 1)) else PuyoPuyo.erase ps |> function | etarget,union,colors,newps when union <= 0 -> ps <- { newps with rensa = 0; union = union; colors = colors } PuyoPuyo.getAllclearScore ps |> fun z -> if z > decimal 0 then gameSe.[4] |> soundPlay ps <- { ps with totalScore = (z |> fun x -> x + ps.totalScore); allclear = true } ps <- { ps with falling = false } cont () if PuyoPuyo.detectCollision ps.current ps.field then ps <- { ps with gameover = true } ; save() updateTimelag := 72. * fps + (15. * float (PuyoPuyo.getLevel ps.erased)) | etarget,union,colors,newps -> List.iter (fun (x,y,_) -> ps.field.[x,y] <- PuyoColors.n) etarget async { newps.rensa |> (fun x -> if x > 19 then chainVoice.[19] else chainVoice.[x]) |> soundPlay } |> Async.Start async { newps.rensa |> (fun x -> if x > 19 then chainSe.[19] else chainSe.[x]) |> soundPlay } |> Async.Start ps <- { newps with rensa = newps.rensa + 1; union = union; colors = colors; erased = newps.erased + union; cheat = false } let scoreBase,magnifyingPower = PuyoPuyo.getScore ps ps <- { ps with totalScore = decimal (scoreBase * magnifyingPower) + ps.totalScore; allclear = false; etarget = etarget; scoreBase = scoreBase; magnifyingPower = magnifyingPower }) fun () -> updateWait := !updateWait + fps + (15. * float (PuyoPuyo.getLevel ps.erased)) if !updateWait > !updateTimelag then updateWait := 0. let puyo = PuyoPuyo.descend ps if PuyoPuyo.detectCollision puyo ps.field |> not then ps <- { ps with current = puyo } if ps.falling && ps.etarget = List.empty then chain (fun () -> ps <- PuyoPuyo.nextPuyo ps) if !updateWait < 36. * fps then ps <- { ps with current = { ps.current with upside = true } } else ps <- { ps with current = { ps.current with upside = false } } do this.Window.Title <- gametitle (320,448) ||> fun x y -> gmanager.PreferredBackBufferWidth <- x ; gmanager.PreferredBackBufferHeight <- y this.TargetElapsedTime <- TimeSpan.FromSeconds(1.0 / fps) override thi.Initialize() = base.Initialize() |> fun _ -> let result = StorageDevice.BeginShowSelector(PlayerIndex.One, null, null) let device = StorageDevice.EndShowSelector(result) loadStorage device ||> fun maxLevel highScore -> ps <- { ps with maxLevel = maxLevel; highScore = highScore } bgm |> soundPlay override this.Update(gameTime) = checkPauseKey () if ps.pause |> not then base.Update gameTime [operateKeys;update] |> List.iter (fun f -> f ()) if not ps.gameover then if PuyoPuyo.detectCollision (PuyoPuyo.descend ps) ps.field then if not ps.falling then gameSe.[2] |> soundPlay; ps <- PuyoPuyo.fixed' ps elif ps.current.pattern = PuyoPuyo.none && not ps.falling then ps <- PuyoPuyo.nextPuyo ps override this.Draw(gameTime) = base.Draw gameTime |> fun _ -> gmanager.GraphicsDevice.Clear(Color.Black) sprite.Force().Begin () sprite.Force().Draw(backgroundTexture.Force(), Vector2.Zero, Color.White) [drawAllClear;drawField;drawNext;drawSukesoudara;drawCarbancle;drawErase;drawRensa;drawLiteral;drawScoreAndLevel;drawPause] |> List.iter (fun f -> f()) sprite.Force().End () override this.EndRun () = base.EndRun(); save() module Program = [<EntryPoint>] let main (args : string[]) = use game = new PuyoGame() in game.Run(); 0
画像データ、音データに関しましては、動画をごらん頂けばわかるとおり配布することはできません。お察しください。
コードを読み理解するとができれば、どんな画像や音データを用意すれば適切に動作させられるかわかるはず。
なお、コードは読めなくてもまったく問題ありません。それでは、CLR/H勉強会でお会いしましょう。
F#でのパターンマッチ。「match a with 〜」よりも 「a |> function 〜」を使おうぜ（異論は認める）
カンスウガタゲンガーは割と見逃しがちだけど、match a with ?と a |> function ?は完全互換ではありません #えふしゃーぷあるある #fsharp
2011-09-02 16:08:23 via web
@zecl え？そうなんですか？まったく同じものだと思ってました。。。
2011-09-02 18:08:31 via HootSuite to @zecl
以前、「F#では、パターンマッチを「match x with」と書く流派と「x |> function」と書く流派がございます。」という記事を書きました。
ほぼほぼ置き換えることが可能な、「match a with 〜」と 「a |> function 〜」ですが、
実は完全互換ではありません。これはカンスウガタゲンガーには割と気づきにくい違いかもしれません。
細かすぎて伝わらない程度の違いですが、カンスウガタゲンガーの@nakamura_toさんにリアクション頂いたのでちょっと書いてみます。
「match a with 〜」と 「a |> function 〜」の違い
結論から申し上げますと、functionによるパターンマッチは"クロージャー"であるということです。「a |> function 〜」をまじまじと見つめていただくとわかるように、とてもクロージャー感を醸し出しています。
「あ〜、言われてみればそうですね。」という感じではないでしょうか。
つまり、「functionによるパターンマッチではmutableな変数をキャプチャすることができない。」という違いがあります。
module Sample = let hoge = let hoge0 () = let mutable s = "ほげ" match s with | "ふが" -> () | x -> printfn "%s" s hoge1 () let hoge1 () = let mutable s = "ほげ" s |> function | "ふが" -> () | x -> printfn "%s" s // mutableな変数をキャプチャできないのでエラー hoge1 () let hoge0 () = let s = ref "ほげ" match !s with | "ふが" -> () | x -> printfn "%s" !s hoge0 () let hoge1 () = let s = ref "ほげ" !s |> function | "ふが" -> () | x -> printfn "%s" !s // Reference CellsはクロージャーでキャプチャできるのでOK hoge1 () () open System open Sample hoge Console.ReadLine () |> ignore
関数プログラミングなパラダイムを主体としているカンスウガタゲンガーは、
極力 mutable を用いないプログラミングをします。mutable を利用するとしても用途はとても限定的です。
また、パターンマッチさせた値を用いずに、直接 mutable な変数をキャプチャするような書き方も好ましくないので、通常そのような書き方はしないでしょう。
ですから、このわずかな違いを意識する機会はあまりないかもしれません。
完全互換ではありませんが、一般的なカンスウガタゲンガーが書く「match a with 〜」は、ほとんどの場合「a |> function 〜」に置き換え可能でしょう。
F#トリビア。いにしえからの言い伝えによると、パターンマッチを「match x with」と書く流派と「x |> function」と書く流派がございます。後者の方がネストを浅く保つことができるので私は好きです。 #fsharp
2011-05-12 16:35:17 via web
いっそのこと、パターンマッチは「a |> function 〜」で行うように統一してしまったほうが(コーディング規約的な意味で)、
パターンマッチ内で直接 mutable な変数をキャプチャするような書き方を抑止することができるので、
カンスウガタゲンガー的にはうれしいのかもしれません（異論は認める）。
好みというよりだだの自己満ですが、「a |> function 〜」の方がイケてると思うので私は多用しまくりんぐです。
F#の勉強会とかやりたい
北海道旭川市近郊でF#の勉強をしてる人 or してみたい人いるかなあ。もしいたら、何かコメントいただきたく。
ふと、Seq.tryFindの変な（誰得な）使い方を思いついた。F#でbreakとcontinue再び。
以前、「F#で楽々breakとcontinue。継続モナドまじパネぇっす！」を書きました。
確かに楽々ではあるんですが、継続モナドとかマジで難しいですよ。
しかも、Visual Studioでデバッグとかまともにできないですし...（´・ω・｀）ｼｮﾎﾞｰﾝな気持ちになっちゃいます。
F#でbreakとcontinue再び
ふと、Seq.tryFindの変な使い方を思いついちゃいました。
ループのbreakとcontinueっぽいものを表現するのに利用できるのではないか、と。
例えば、こんな風に書けます。「do! continue' else」のところがカッコワルイのはご愛嬌。
open System printfn "%s" "----- for" let hoge = let x = ref "／(^o^)＼" loop {for i in [1..10] do if i = 5 then printfn "%s" "five" do! continue' else if i = 2 then printfn "%s" "two" do! continue' else printfn "%d" i if i = 7 then printfn "%s" "!!!" x := "＼(^o^)／" return break' printfn "%d" i printfn "%s" "!" } !x hoge |> printfn "%s" printfn "%s" "----- while" let fuga = let x = ref "／(^o^)＼" loop {let i = ref 0 while !i < 6 do i := !i + 1 if !i = 5 then printfn "%s" "five" do! continue' else if !i = 2 then printfn "%s" "two" do! continue' else printfn "%d" !i if !i = 7 then printfn "%s" "!!!" x := "＼(^o^)／" return break' printfn "%d" !i printfn "%s" "!"} !x fuga |> printfn "%s" Console.ReadLine () |> ignore
実行結果
----- for 1 ! two 3 ! 4 ! five 6 ! 7 !!! ＼(^o^)／ ----- while 1 ! two 3 ! 4 ! five 6 ! ／(^o^)＼
LoopBuilder
Seq.tryFindの使い方が変ですｗ optionの使い方が変ですｗ
// へぼいループビルダー type LoopBuilder () = let while' gd body = (fun _ -> let b = gd() if b then if Option.isSome (body ()) then Some () else body () |> (fun _ -> None) else Some ()) |> Seq.initInfinite member this.While(gd,body) = while' gd body |> Seq.tryFind (fun x -> Option.isSome x) |> ignore member this.For (s, f) = s |> Seq.tryFind (fun x -> Option.isSome (f x)) |> ignore member this.Zero () = None member this.Combine (a,b) = a |> function |Some x -> Some x |_ -> b() member this.Return (x) = x member this.ReturnFrom (x) = Some x member this.Bind (m,f) = m |> function |Some x -> f x |> Some |_ -> None member this.Delay f = f member this.Run f = f () let break' = Some () let continue' = None let loop = LoopBuilder ()
わー！まったく難しいことをしていないシンプルな実装で、ループのbreakとcontinueな動作を表現できちゃったっぽいよ？
でも、やっぱり「do! continue' else」の部分がトテモカコワルイ。誰得かと（´・ω・｀）
Imperative computation builder
ちゃんとカッコヨクやりたい人は、tomaspさんの「 Imperative computation builder 」あたりをあたった方が間違いなくよいです。
http://tomasp.net/blog/imperative-ii-break.aspx
http://fssnip.net/40
お知らせ
第６１回CLR/H勉強会(TechParty2011)で、F# MVPのぶひささん( @nobuhisa_k )と、ASP.NET MVPさかもとさん( @jsakamoto )と、「F#パネルディスカッション 2011」に登壇します。F#の魅力についてお話したいと思います。
CLR/H 公式ページ
http://clr-h.jp/
TechParty2011
http://techparty2011.iinaa.net/
