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

ScalazのValidationもFSharpxのValidationもApplicative

プログラミング FSharpx Scalaz Scala F# Applicative 息抜き



ドラゴンズドグマが楽しみだったり、しおりを温めていたScala実践プログラミングの読書を再開したりな今日この頃。
ご多聞に漏れずわたくしも五月病なので軽めのネタで。とゆーかですね、FSharpxのステマです。



FSharpxのValidationでFizzBuzz

元ネタ

ScalazのValidationでFizzBuzz
http://d.hatena.ne.jp/terazzo/20111015/1318692810


続・ScalazのValidationでFizzBuzz
http://d.hatena.ne.jp/terazzo/20111018/1318959813



そもそものきっかけはこのあたり


ScalazのValidationの謎
http://d.hatena.ne.jp/terazzo/20111022/1319295098




勉強になります。ということで、「ScalazのValidationはモナドではない」であっていました。しかしながら、Scalazの場合は「動作を変えてモナドのインスタンスにすることもできる」んですね。でもそれってどうなの？エラー情報をaccumulateしないValidationって一体何。とっても意味ないんじゃー感がするんですが。できるというだけでやらないですね。



で、FSharpxというF#のOSSライブラリでも同じくValidationが実装されていまして、エラーをListMonoidとして扱ってエラー情報をaccumulateします。もちろんFSharpxのValidationもモナドではなくアプリカティブ(Applicative)として実装されています。ちょっと関連する以下のようなつぶやきも踏まえつつ、FSharpxと友達になるべくこれでFizzBuzzしてみましょう。




FSharpxの中の人的には、Choice<'T1,'T2>が生で使われちゃうこともある程度許容しているような雰囲気もなくはないですが、
生でヤっちゃうといろいろとアレということで、判別供用体のChoice1Of2とChoice2Of2を申し訳程度にラップしておく。

let success = Choice1Of2
let failure = Choice2Of2

open FSharpx.Validation

let createChoice d s = fun n -> 
  if n % d = 0 |> not then 
    success n
  else 
    failure [s]

let fizz = createChoice 3 "Fizz"
let buzz = createChoice 5 "Buzz"
let (<*) a b = lift2 (fun x _ -> x) a b
let fizzbuzz n = 
  fizz n <* buzz n
  |> function 
  | Success n -> string n
  | Failure e -> List.fold (fun a b -> b + a) "" e

[1..100] |> Seq.iter (fun x -> fizzbuzz x |> printfn "%s")

System.Console.ReadLine () |> ignore

って、ちょっと待って。FSharpxにおいてもValidationはちゃーんとApplicative考慮されていますし、当然のようにプログラムをApplicativeスタイルで書くための(<*)演算子はValidationモジュールにすでに定義済みです。上でわざわざ書いたのは、lift2していますよということを強調したかっただけでした。あとついでといっちゃーなんですが、お気に入りの「にっこり演算子」もおまけで追加しておきましょう。

let success = Choice1Of2
let failure = Choice2Of2
let (^-^) x f = x f (* にっこり *)

open FSharpx.Validation

let createChoice d s = fun n -> 
  if n % d = 0 |> not then 
    success n
  else 
    failure [s]

let fizz = createChoice 3 "Fizz"
let buzz = createChoice 5 "Buzz"
let fizzbuzz n = 
  fizz n <* buzz n
  |> function 
  | Success n -> string n
  | Failure e -> List.fold (fun a b -> b + a) "" e

[1..100] |> Seq.iter ^-^ fun x -> fizzbuzz x |> printfn "%s"

System.Console.ReadLine () |> ignore


シンプル。Validation本来の使い方とはちとズレていますが、サンプルとしてはイメージがつかみやすく結構わかり良いんじゃないでしょうか。元ネタのterazzoさんナイスですね。


参考
Scala の Either についての考察
http://d.hatena.ne.jp/xuwei/20110927/1317156625

Scalaz 6.0.4 と Haskell (GHC7.4.1) を比べてみることによってScalazのclassを分類して理解してみる
http://d.hatena.ne.jp/xuwei/20120204/1328377968


twitterで回答してくださった@xuwei_kさんの記事、参考になりました。

Retry Monad for Transient Fault Handling (Topaz + FSharpx)

プログラミング F# C# Windows Azure Enterprise Library FSharpx モナド モナド則


4月14日に札幌で行われた第69回CLR/H勉強会にて、「Retry Monad for Transient Fault Handling - F#とWindows Azure と私 -」と題して、ライトニングトークで発表しました。

Retry monad for transient fault handling
View more presentations from zecl1231


Microsoft Enterprise Library 5.0 Integration Pack for Windows Azure(EL5 for Azure)のTopaz および FSharpx を利用してモナドを作りました。Topazを利用する理由は、再利用可能な再試行戦略およびWindows Azure向けの検出戦略が組み込み済みであり、それをそのまま利用したいからです。EL5 for AzureはOSSなので、どのような実装がなされているか実際に確認することができるので、すべてをF#で書き直すこともできますが、それでは車輪の再発明になってしまいます。Retry Monad for Transient Fault Handling は、一時的障害が発生するかもしれない計算について、それぞれ異なるRetryPolicyを適用しながら再試行処理を行います。一時的な障害に対するリトライ処理をひとつの計算として包括的に扱うことができるモナド実装です。このRetryモナドの計算結果は、Choice<’T1,’T2>型で得ることができ、これによりFSharpxで定義済みの Eitherモナドで扱うこともできます。



Retry Monad for Transient Fault Handling

namespace Monad.Retry 
open System

[<AutoOpen>]
module Retry =
  // #r "Microsoft.Practices.TransientFaultHandling.Core"
  // #r "FSharpx.Core"
  open Microsoft.Practices.TransientFaultHandling
  open FSharpx
 
  [<Sealed>]
  type TransientErrorCatchAllStrategy () =
    interface ITransientErrorDetectionStrategy with
      member this.IsTransient (ex : exn)  = true

  [<Sealed>]
  type TransientErrorIgnoreStrategy () =
    interface ITransientErrorDetectionStrategy with
      member this.IsTransient (ex : exn)  = false

  let defaultRetryStrategyName = "DefaultRetry"
  let defaultRetryCount = 3
  let defaultMinBackoff = TimeSpan.FromSeconds(3.0)
  let defaultMaxBackoff = TimeSpan.FromSeconds(90.0)
  let defaultDeltaBackoff = TimeSpan.FromMilliseconds(30.0)

  let (<+) (rp:RetryPolicy<'TResultStrategy>) retrying = rp.Retrying |> Event.add(retrying)

  type RetryPolicies =
    static member NoRetry() = new RetryPolicy<TransientErrorIgnoreStrategy>(0, TimeSpan.Zero)
    static member Retry<'TTransientErrorCatchStrategy when 'TTransientErrorCatchStrategy : (new :unit -> 'TTransientErrorCatchStrategy) and 'TTransientErrorCatchStrategy :> ITransientErrorDetectionStrategy>(retryCount : int , retryInterval : TimeSpan) : RetryPolicy<'TTransientErrorCatchStrategy> =
      new RetryPolicy<'TTransientErrorCatchStrategy>(retryCount, retryInterval)
    static member Retry<'TTransientErrorCatchStrategy when 'TTransientErrorCatchStrategy : (new :unit -> 'TTransientErrorCatchStrategy) and 'TTransientErrorCatchStrategy :> ITransientErrorDetectionStrategy>(retryCount : int , initialInterval : TimeSpan, increment : TimeSpan) : RetryPolicy<'TTransientErrorCatchStrategy> =
      new RetryPolicy<'TTransientErrorCatchStrategy>(retryCount, initialInterval, increment)
    static member Retry<'TTransientErrorCatchStrategy when 'TTransientErrorCatchStrategy : (new :unit -> 'TTransientErrorCatchStrategy) and 'TTransientErrorCatchStrategy :> ITransientErrorDetectionStrategy>(retryStrategy : RetryStrategy) : RetryPolicy<'TTransientErrorCatchStrategy> =
      new RetryPolicy<'TTransientErrorCatchStrategy>(retryStrategy)
    static member RetryExponential<'TTransientErrorCatchStrategy when 'TTransientErrorCatchStrategy : (new :unit -> 'TTransientErrorCatchStrategy) and 'TTransientErrorCatchStrategy :> ITransientErrorDetectionStrategy>(retryCount : int , deltaBackoff : TimeSpan) : RetryPolicy<'TTransientErrorCatchStrategy> =
      let retryStrategy = new ExponentialBackoff(defaultRetryStrategyName, retryCount, defaultMinBackoff, defaultMaxBackoff , deltaBackoff)
      new RetryPolicy<'TTransientErrorCatchStrategy>(retryStrategy)
    static member RetryExponential<'TTransientErrorCatchStrategy when 'TTransientErrorCatchStrategy : (new :unit -> 'TTransientErrorCatchStrategy) and 'TTransientErrorCatchStrategy :> ITransientErrorDetectionStrategy>(retryCount : int , minBackoff : TimeSpan, maxBackoff : TimeSpan, deltaBackoff : TimeSpan) : RetryPolicy<'TTransientErrorCatchStrategy> =
      let retryStrategy = new ExponentialBackoff(defaultRetryStrategyName, retryCount, minBackoff, maxBackoff, deltaBackoff)
      new RetryPolicy<'TTransientErrorCatchStrategy>(retryStrategy)
    static member RetryDefault(?retryCount : int) : RetryPolicy<TransientErrorCatchAllStrategy>=
      let retryCount = defaultArg retryCount defaultRetryCount
      RetryPolicies.RetryExponential<TransientErrorCatchAllStrategy>(retryCount, defaultMinBackoff, defaultMaxBackoff, defaultDeltaBackoff)

  type Retry<'TResult> = Retry of (Lazy<unit -> 'TResult * LastException option>)
  and RetryResult<'TResult> = Choice<'TResult, LastException>
  and LastException = exn

  let exnHandler e = Retry(lazy(fun () -> Unchecked.defaultof<'TResult>, e |> Some))    
  type RetryBuilder (policy : RetryPolicy) = 
    new(?retryCount : int, ?retrying) = 
      let policy = 
        let retryCount = defaultArg retryCount defaultRetryCount
        RetryPolicies.RetryDefault(retryCount)

      retrying |> function
      | None   -> policy <+ (fun e -> printfn "%s" (sprintf "RetryPolicyName:%s, CurrentRetryCount:%d, LastException.Message:%s, Delay:%A" 
                                                            policy.RetryStrategy.Name e.CurrentRetryCount e.LastException.Message e.Delay))
      | Some retrying ->policy <+ retrying
      RetryBuilder(policy)
    
    member this.Bind (m : Retry<'TResult>, bind : ('TResult) -> Retry<'UResult>) : Retry<'UResult> = 
      Retry(lazy(fun () -> 
        m |> function
        | Retry f -> f.Force() |> fun cont -> 
          cont() ||> fun r _ -> r |> bind
        |> function
          | Retry f -> f.Force() 
          |> fun cont -> policy.ExecuteAction(Func<_>(fun () -> cont() ||> fun r _ -> r,None))))
    member this.Return (value : 'TResult) : Retry<'TResult> = 
      Retry(lazy (fun () -> policy.ExecuteAction(L.F<_>(fun () ->  value, None))))
    member this.ReturnFrom (m : Retry<'TResult>) : Retry<'TResult> = 
      m
    member this.Delay (f: unit -> Retry<unit -> 'TResult>)  : Retry<unit -> 'TResult> = 
      Retry(lazy (fun () -> policy.ExecuteAction(L.F<_>(fun () -> f() |> function | Retry f -> f.Force() |> fun cont -> cont() ||> fun f _ -> f(), None)) ||> fun r _ ->  (fun () -> r), None))
    member this.Zero () : Retry<'TResult> = 
      this.Return(Unchecked.defaultof<'TResult>)
    member this.Combine(comp1:Retry<'TResult>, comp2:Retry<'TResult>) = 
      this.Bind(comp1,(fun r -> comp2))

  let retry = new RetryBuilder()

  open Operators
  let inline returnM x = returnM retry x 
  let inline (>>=) m f = bindM retry m f
  let inline (=<<) f m = bindM retry m f
  let inline (<*>) f m = applyM retry retry f m
  let inline ap m f = f <*> m
  let inline map f m = liftM retry 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 retry m (fun _ -> f)
  let inline (>=>) f g = fun x -> f x >>= g
  let inline (<=<) x = flip (>=>) x

  let (|RetryResult|) = 
    let rec result (r:RetryResult<'TResult>) =
      match r with
      | Choice1Of2 v -> v, None
      | Choice2Of2 e -> Unchecked.defaultof<'TResult>, Some(e)
    result

  let run (retryCont : Retry<unit -> 'TResult>) : RetryResult<'TResult> =
    try
      retryCont |> function
      |(Retry f) -> f.Force()() ||> fun r e -> 
        e |> function
        |Some e -> e |> Choice2Of2
        |None   -> r() |> Choice1Of2
    with e -> e |> Choice2Of2



一時的な障害：Windows Azure(クラウド)アプリケーションを開発するにあたって対処しなければならない課題のひとつ

他のクラウドサービスに依存するようなクラウドアプリケーションを開発する場合に開発者が対処しなければならない課題の一つに、“一時的な障害” があります。インフラストラクチャレベルの障害であったり、ネットワークの問題など一時的な条件のために発生する恐れのある障害のことです。この一時的に発生しうる障害は、ほとんどの場合は短い間隔で（ほんの数ミリ秒後に）リトライ処理を行うことで回避することができます。


たとえば、Windows Azureで SQL Azureプラットフォームを利用する場合。SQL Azureサービスは、共有リソース上で大規模なマルチテナントデータベースとしてサービスが提供されるので、データベースを利用するすべての利用者に対して良好なエクスペリエンスを提供しなければなりません。そのため、SQL Azureは過剰なリソースの使用や、実行時間の長いトランザクションの発行された場合など、さまざまな理由でサービスへの接続数を抑制して、利用者が意図しないタイミングで接続を切断することがあります。これが、SQL Azureを利用した場合に生じる一時的な障害ということになります。このような障害が発生した場合であってもシームレスなユーザーエクスペリエンスを提供するために、Windows Azureアプリケーション(クラウドアプリケーション)では、一時的な障害によって処理が中断された場合にはリトライを試みるようにアプリケーションを実装する必要があります。


Microsoft Enterprise Library 5.0 Integration Pack for Windows Azureを利用する

一時的な障害に対応するアプリケーションを実装する場合、Microsoft Enterprise Library 5.0 Integration Pack for Windows Azure(以降 EL5 for Azure)を利用するのが有効です。EL5 for Azureは、マイクロソフトの pattern & practice チームによる、マイクロソフト製品やテクノロジを基として、アプリケーションを構築する上でのパターンやベストプラクティスを集めたライブラリの Windows Azure向けの拡張パックです。この拡張ライブラリが提供されるまでは、一時的障害を検知してリトライ処理を行う実装を開発者自身がおのおので組み込まなければなりませんでした。EL5 for Azureには、Transient Fault Handling Application Block (Topaz)という、Windows Azureのプラットフォームに含まれるサービス利用時に発生するさまざまな一時的な障害からWindows Azureアプリケーションを回復させるためのアプリケーションブロックが提供されています。これは、Windows Azure固有の一時的な障害のみならず、オンプレミスアプリケーションで発生するさまざまな一時的な障害に対するリトライ処理についても利用可能なように設計されており、リトライ処理について高いレベルで抽象化されたアプリケーションブロックです(Microsoft.Practices.TransientFaultHandling.Core.dllにまとめらえている)。特に、Windows Azureに特化した組み込みの実装については、SQL Azure、Windows Azure ストレージサービス、Windows Azure サービスバス、Windows Azure キャッシングサービス向けの検出戦略がそれぞれ提供されていて、Microsoft.Practices.EnterpriseLibrary.WindowsAzure.TransientFaultHandling.dllに含まれています。



検出戦略と再試行戦略

検出戦略は、ITransientErrorDetectionStrategyインターフェイスを実装して作成することができます。

public interface ITransientErrorDetectionStrategy
{
    bool IsTransient(Exception ex);
}

例外を引数で受け取り、その例外の種類や内部的なメッセージなどを判断して、リトライ処理を行うときは true、 リトライをせずに無視するときは falseを返すように実装するだけの非常にシンプルなインターフェイスです。Windows Azureの一時的な障害に対する4つの組み込み検出戦略として、SqlAzureTransientErrorDetectionStrategy、StorageTransientErrorDetectionStrategy、ServiceBusTransientErrorDetectionStrategy、CacheTransientErrorDetectionStrategyが提供されています。




再試行戦略は、RetryStrategy抽象クラスを継承して作成することができます。

    public abstract class RetryStrategy
    {
        public static readonly int DefaultClientRetryCount = 10;
        public static readonly TimeSpan DefaultClientBackoff = TimeSpan.FromSeconds(10.0);
        public static readonly TimeSpan DefaultMaxBackoff = TimeSpan.FromSeconds(30.0);
        public static readonly TimeSpan DefaultMinBackoff = TimeSpan.FromSeconds(1.0);
        public static readonly TimeSpan DefaultRetryInterval = TimeSpan.FromSeconds(1.0);
        public static readonly TimeSpan DefaultRetryIncrement = TimeSpan.FromSeconds(1.0);
        public static readonly bool DefaultFirstFastRetry = true;

        public static readonly RetryStrategy NoRetry = new FixedInterval(0, DefaultRetryInterval);
        public static readonly RetryStrategy DefaultFixed = new FixedInterval(DefaultClientRetryCount, DefaultRetryInterval);
        public static readonly RetryStrategy DefaultProgressive = new Incremental(DefaultClientRetryCount, DefaultRetryInterval, DefaultRetryIncrement);
        public static readonly RetryStrategy DefaultExponential = new ExponentialBackoff(DefaultClientRetryCount, DefaultMinBackoff, DefaultMaxBackoff, DefaultClientBackoff);

        protected RetryStrategy(string name, bool firstFastRetry)
        {
            this.Name = name;
            this.FastFirstRetry = firstFastRetry;
        }

        public bool FastFirstRetry { get; set; }
        public string Name { get; private set; }
        public abstract ShouldRetry GetShouldRetry();
    }


基本的な実装は、GetShouldRetryメソッドをオーバーライドし、リトライすべきタイミングか否かを表すShouldRetry デリゲートを返すように実装します。

public delegate bool ShouldRetry(int retryCount, Exception lastException, out TimeSpan delay);


ShouldRetry デリゲートは、リトライする回数と最後に発生した例外およびリトライを行うタイミングの遅延間隔を受け取り、リトライ処理を行うべきタイミングか否かを返します。組み込みで、Incremental(再試行と再試行間の増分の時間間隔数を制御する戦略)、FixedInterval(再試行と一定間隔の再試行間を制御する戦略)、ExponentialBackoff(指数関数的な遅延を計算するためのバックオフ戦略)が提供されています。



Transient Fault Handling Application Block (Topaz)によるリトライ処理の基本的な利用方法


Transient Fault Handling Application Block (Topaz)による基本的な利用方法(C#)は、検出戦略と再試行戦略を組み合わせて、RetryPolicyオブジェクトを作成し、そのRetryPolicyオブジェクトにリトライ中の処理を適宜設定し、RetryPolicyオブジェクトのExecuteActionメソッドを呼び出します。ExecuteActionメソッドへは、リトライを行いたい対象の処理を継続渡しスタイルで渡します。

var strategy = new Incremental("Incr1",10, TimeSpan.FromSeconds(1), TimeSpan.FromSeconds(1));
var policy = new RetryPolicy<SqlAzureTransientErrorDetectionStrategy>(strategy);

policy.Retrying += (_, e) =>
{
	Console.WriteLine("{0:HH:mm:ss.fff} RetryCount: {1}, ErrorMessage: {2}, StackTrace: {3}",
	    DateTime.Now,
	    e.CurrentRetryCount,
	    e.LastException.Message,
	    e.LastException.StackTrace);
};

var result = policy.ExecuteAction(() =>
{
	// SQL Azureへごにょごにょ

	return "クエリの結果などを返す";
});

EL5 for Azureはオブジェクト指向プログラミングで書かれているライブラリ、FSharpxは関数プログラミングで書かれているライブラリです。これら異なるパラダイムの部品を組み合わせてモナドを作る。とっても面白いですね。



モナドとは

モナドは単なる自己関手の圏におけるモノイド対象だよ。何か問題でも？ - フィリップ・ワドラー


圏論を少しかじったことがある人にとっては問題ない説明なのですが、そうではない場合「日本語でおｋ」と言わざるを得ません。
この説明だけでは少々乱暴すぎるので、MSDN - コンピューテーション式(F#)へのリンクと、F#とモナドの関係について参考になりそうな表を置いておきます。


コンピュテーション式 (F#)
http://msdn.microsoft.com/ja-jp/library/dd233182(v=vs.110).aspx


Haskell F# 数学(圏論)
return return η（単位元：unit）
>>= bind (*)operator
型クラスMonadのインスタンスであるように実装する コンピューテーション式で少なくとも Return と Bind の２つのmemberを実装する NA
Monad Computation Expression, Workflow モナドはKleisliトリプルと等価な定義。F# と Haskell の中で定義されるモナドの構造は実際にKleisliトリプル。
functor through a type class definition usually not mentioned 関手(functor)
function function (fun) 射(morphism)
Haskellのデータ型のHask圏 .Netデータ型の圏 グループ、位相、グラフ、微分幾何学
composable functions composable functions 2項演算とモノイド

MSDN - Code Recipe - F#によるモナドの実装方法とモナド則を確認するユニットテスト。 Retry Monad for Transient Fault Handling

モナド則を確認するためのユニットテスト等を含む、このプログラムコードのソリューションファイル一式を、MSDN - Code Recipe よりダウンロードすることができます。

http://code.msdn.microsoft.com/F-Retry-Monad-for-35ee1e72


関連記事
快刀乱麻を断つモナド - F#とIOモナドとコンピューテーション式の奥義と
http://d.hatena.ne.jp/zecl/20110703/p1

knockout.jsを利用したMVVMによるコンポーネント作成。WebGridの基本的な使い方と、Pagerヘルパーの利用。

プログラミング ASP.NET MVC3 Entity Framework knockout.js jQuery JavaScript MVVM JSON C#


MSDN - Code Recipeに初投稿しました。

WebGridに関するまとまった説明や、ページングに関するTipsもなぜか少なかった気がしたので、書いてみました。
サンプルコードを書いただけで力尽きたので細かい説明はありませんが、詳細については以下をご覧ください。


knockout.jsを利用したMVVMによるコンポーネント作成。WebGridの基本的な使い方と、Pagerヘルパーの利用。
http://code.msdn.microsoft.com/knockoutjsMVVMWebGridPager-e675c134

いまさらASP.NET MVCのモデルバインダ入門あれこれ。MEFのカスタムエクスポートプロバイダーは設計の幅を広げる。自動拡張型カスタムモデルバインダプロバイダーを作ろう。

プログラミング C# MEF ASP.NET MVC3


http://www.asp.net/



ASP.NET MVC4 Betaがリリースされまして、WebAPIいいね！な今日この頃。誰が言ったか、これから求められるIT技術は、Web、クラウド、関数型言語の三本柱らしいです。とは言っても、世の中にはさまざまな技術が溢れています。.NETerなわたしは月並みですが、ASP.NET MVC、Windows Azure、F#を追いかけるつもりです。まぁ、日進月歩の業界ですし、わたし自身飽きっぽかったりするので来年には違うことを言っているかもしれません。最近の私はと言えば、月９ドラマ「ラッキーセブン」でメカオタ少女茅野メイ役を演じている入来茉里さんのファンになりました。スピンオフドラマの「敷島☆珈琲〜バリスタは見た！？〜」も面白い。これからブレイクすること間違いありません。



それはさておき、ASP.NET MVC関連の記事はだんだんと増えてきていますが、なぜか基本中の基本であるカスタムモデルバインダですとか、カスタムモデルバインダプロバイダーに関する記事があまりにも少ない。少なすぎて困っているASP.NET MVC入門者も少なくないと聞いています（要出典）。誰かの役に立つかもしれないということで、いまさらながらASP.NET MVC3のモデルバインダ入門あれこれについてちょっと書いておきます。



このエントリーの主な話題。わりと盛りだくさん。

・カスタムモデルバインダについて
・カスタムモデルバインダプロバイダーについて
・Base64でシリアル化可能なモデルと、その汎用モデルバインダについて
・カスタムモデルバインダでアノテーション検証を有効にする
・MEFのカスタムエクスポートプロバイダーについて
・MEFを用いた自動拡張型カスタムモデルバインダプロバイダーについて
・IModelBinderProviderインターフェイスがイケてない説

この記事のサンプルコード一式はSkyDriveへあげておきます。



すてきなモデルバインダ

ASP.NET MVC にはモデルバインダという仕組みがあり、比較的新しいMVCフレームワークで採用されていて、たとえばJavaScript製のMVCフレームワークなんかでもよく採用されているデータバインド手法です。ASP.NET MVCでは、モデルバインダと呼ばれるクラスでリクエストデータ等を使って厳密に型付けされたオブジェクトを作成して、ルーティングやクエリ、フォームパラメータなどに、コントローラーのアクションに対するパラメータの型とのバインディングが管理されます。同名のパラメータについてデータバインドを試みてコントローラのアクションを単純化してくれるし、コントローラー内に「値の変換を行う」というノイズとなる処理がなくなるので、開発者はコントローラー本来の役割の実装に集中できるようなります。素敵ですね。モデルバインディングを実際に実行するのはSystem.Web.Mvc.IModelBinderを実装したクラスで、既定ではSystem.Web.Mvc.DefaultModelBinderクラスが適用されます。この既定で動作するバインダは、文字や数値など.NETで扱う基本的な型や、アップロードされたファイルなど様々な型に対応しています。小規模またはシンプルなシナリオでは、この既定のモデルバインダが自動的に基本的な型をバインドしてくれるので、この動作について特別意識することはあまりないでしょう。ただ、世の中そんなにあまくないのが現実です。大規模または複雑なシナリオでは、既定のバインディングでは十分ではないこともあるでしょう。そのような場合、カスタムモデルバインダ（ModelBinderの拡張）を作成することになります。



既定のモデルバインダが実際にどんな働きをしてくれるのかを一目でわかるように書くと、

[HttpPost]
public ActionResult Create()
{
	var customer = new Customer() 
	{
		CustomerId = Int32.Parse(Request["customerId"]), 
		Description = Request["description"], 
		Kind = (CustomerKind)Enum.Parse(typeof(CustomerKind), Request["kind"]), 
		Name = Request["name"], 
		Address = Request["address"]
	};

	// …

	return View(customer);
};


既定のDefaultModelBinderが処理できる範囲内であれば、上記のような煩雑な型の変換処理をまったく書かなくてよくて、下記のようにシンプルに書けるようになります。

public ActionResult Create(Customer customer) 
{ 
	// … 

	return View(customer);
}


モデルバインダって、とてもかわいいですね。はい。って、ASP.NET MVC3を使ってプログラミングをしている人には当たり前のことでしたね。



モデルバインダの拡張

さて、「大規模または複雑なシナリオでは、既定のバインディングでは十分ではないこともあるでしょう。」と前述しました。そのようなシナリオでは、モデルバインダの拡張、すなわち独自にカスタムモデルバインダを作成することで、さまざなシナリオに対応することができます。



モデルバインダの拡張の方法としては、IModelBinderインターフェイスを実装するか、もしくはIModelBinderを実装している既定のDefaultModelBinderクラスを継承して実装します。IModelBinderインターフェイスを実装する方法の場合は、object BindModel(...)メソッドを実装するだけというシンプル設計。


DefaultModelBinderを継承して作る場合の主な拡張ポイントとしては以下のものがあり、適宜必要なものをオーバーライドして実装します。

object BindModel(...);			// モデルバインド実行
object CreateModel(...);		// モデル型オブジェクト生成
bool OnModelUpdating(...);		// モデル更新開始
void OnModelUpdated(...);		// モデル更新完了
bool OnPropertyValidating(...);		// プロパティ検証開始
void OnPropertyValidated(...);		// プロパティ検証完了

また、拡張した自作のモデルバインダはいくつかの異なるレベルで登録することができて、これにより非常に柔軟にバインディング方法を選択できます。

// Application_Start()で登録する方法
ModelBinders.Binders.DefaultBinder = new CustomModelBinder();
ModelBinders.Binders.Add(typeof(MyModel), new CustomModelBinder());

// Actionの引数に属性で指定する方法
[ModelBinder(typeof(CustomModelBinder))]


他にも、ModelBinderProviderを登録して対応することもできます。これについては後程述べます。



カスタムモデルバインダを作ろう


ではカスタムモデルバインダを作成してみましょう。以下のようなユーザー定義のモデルを含む単純なViewModelをバインドしたい場合を考えます。

namespace ModelBinderSample.Models.ViewModel
{
    public class SampleViewModel0
    {
        public Sample0 Child { get; set; }
    }
}

using System.ComponentModel.DataAnnotations;
using ModelBinderSample.Models.ViewModel;

namespace ModelBinderSample.Models
{
    public enum Hoge
    {
        Test1,
        Test2,
        Test3
    }

    public class Sample0 
    {
        public Hoge Hoge { get; set; }

        [Display(Name = "ただのプロパティ")]
        public string NomalProperty { get; set; }
    }
}


IModelBinderインターフェイスを実装する方法を試してみましょう。例えば、下記サンプルのように実装することができます。object BindModel(...)メソッドの基本実装は、リクエストを適切な型に変換して返してあげる処理を書くだけです。実用性はありませんが下記サンプルのように値を直接編集したりもできますし、他にも値を検証してエラーメッセージを追加したりすることもできます。

using System;
using System.Web;
using System.Web.Mvc;
using ModelBinderSample.Models.ViewModel;

namespace ModelBinderSample.Models.ModelBinder
{
    public class SampleViewModel0Binder : IModelBinder
    {
        public object BindModel(ControllerContext controllerContext, ModelBindingContext bindingContext)
        {
            HttpRequestBase request = controllerContext.HttpContext.Request;

            var model = new Sample0()
            {
                Hoge = (Hoge)Enum.Parse(typeof(Hoge), request.Form.Get("Child.Hoge"), false),
                NomalProperty = request.Form.Get("Child.NomalProperty") + "だってばよ！",
            };

            return new SampleViewModel0() { Child = model };
        }
    }
}


ビュー：Sample0/Index.cshtml

@using ModelBinderSample.Models
@using ModelBinderSample.Models.ViewModel
@model SampleViewModel0
           
@{
    ViewBag.Title = "Sample0";
}

<h2>@ViewBag.Message</h2>

@using (Html.BeginForm("Index", "Sample0"))
{

    @Html.TextBoxFor(vm => vm.Child.NomalProperty, new { @style = "width: 350px;" }) 
    @Html.HiddenFor(vm => vm.Child.Hoge)

    <br />    
    <input type="submit" value="送信" />
}

コントローラー：Sample0Controller.cs

using System;
using System.Web.Mvc;
using ModelBinderSample.Models;
using ModelBinderSample.Models.ViewModel;

namespace ModelBinderSample.Controllers
{
    public class Sample0Controller : Controller
    {
        public ActionResult Index()
        {
            ViewBag.Message = "ASP.NET MVC へようこそ";


            var vm = new SampleViewModel0()
            {
                Child = new Sample0()
                {
                    Hoge = Models.Hoge.Test2,
                    NomalProperty = "うずまきナルト",
                }
            };

            return View(vm);
        }

        [HttpPost]
        [AcceptVerbs(HttpVerbs.Post)]
        public ActionResult Index(SampleViewModel0 vm)
        {
            ViewBag.Message = "ASP.NET MVC へようこそ";

            if (!ModelState.IsValid)
            {
                return View(vm);
            }

            return View(vm);
        }

        public ActionResult About()
        {
            return View();
        }
    }
}

モデルバインダの登録

protected void Application_Start()
{
    AreaRegistration.RegisterAllAreas();

    // Add ModelBinder
    ModelBinders.Binders.Add(typeof(SampleViewModel0), new SampleViewModel0Binder());

    RegisterGlobalFilters(GlobalFilters.Filters);
    RegisterRoutes(RouteTable.Routes);
}


内容はお粗末ですが、カスタマイズはできました。もう少し踏み込んだカスタマイズについては後半で。


ModelBinderProviderの拡張 : カスタムモデルバインダプロバイダー

モデルの型ごとに適切なモデルバインダを供給するクラス。それがモデルバインダプロバイダー。もっと噛み砕いて言うと、「このモデルの型の場合は、このモデルバインダを使ってバインディングしてくださいね〜」って情報を供給してくれるクラスです。カスタムモデルバインダプロバイダーは、IModelBinderProviderインターフェイスを実装して作ることができます。



SampleViewModel0モデルのカスタムモデルバインダプロバイダーを実装サンプル


SampleViewModel0BinderProvider.cs

using System;
using System.Collections.Generic;
using System.Linq;
using System.Web;
using System.Web.Mvc;
using ModelBinderSample.Models.ModelBinder;
using ModelBinderSample.Models.ViewModel;
using ClassLibrary1;

namespace ModelBinderSample.Models.ModelBinderProvider
{
    public class SampleViewModel0BinderProvider : IModelBinderProvider
    {
        public IModelBinder GetBinder(Type modelType)
        {
            if (modelType == typeof(SampleViewModel0))
                return new SampleViewModel0Binder();
            return new DefaultModelBinder();
        }
    }
}

このサンプルでは、型がSampleViewModel0であるとき、SampleViewModel0Binderを返し、それ以外の型のときは既定のモデルバインダを返しているだけなので、プロバイダーとしてはあまり意味がありません。通常は、さまざまなモデルの型に応じて異なるモデルバインダを返すようなモデルバインダプロバイダーを作ります。


モデルバインダプロバイダーの登録

protected void Application_Start()
{
    AreaRegistration.RegisterAllAreas();

    // Add ModelBinderProvider
    ModelBinderProviders.BinderProviders.Add(new SampleViewModel0BinderProvider());

    RegisterGlobalFilters(GlobalFilters.Filters);
    RegisterRoutes(RouteTable.Routes);
}



Base64でシリアル化可能なモデルと、その汎用モデルバインダ

もう少し踏み込んだカスタムモデルバインダの例を見てみます。例としてはあまりよろしくはないですが、こういう実装もできるんだよというサンプルとして、Base64でシリアル化可能なModelをバインドするための汎用的なモデルバインダを作ってみましょう。例えば、ViewModelにユーザー定義の型のプロパティを含むような場合、当然 DefaultModelBinder ではそのような型をバインドできませんので、コントローラーのアクションパラメータとうまくバインドできずに、そのViewModelのプロパティにはnullが設定されてしまいます。そこで任意の型についてBase64形式でシリアル化可能なモデルをバインドするような、汎用的なカスタムモデルバインダを考えてみます。



ひどく曖昧な抽象化ですが、まずシリアル化可能なモデルであることを表すインターフェイスを定義します。BindTypeプロパティでは、バインドする型（つまりはモデル自身の型）を返すように実装します。ToStringメソッドでは、Base64エンコードした文字列を返すように実装します。


ISerializableModel.cs

using System;

namespace ClassLibrary1
{
    public interface ISerializableModel
    {
        Type BindType { get; }
        string ToString();
    }
}



そのインターフェイスを実装しただけの抽象クラス。相変わらず曖昧模糊。


AbustractSerializableModel.cs

using System;

namespace ClassLibrary1
{
    [Serializable]
    public abstract class AbustractSerializableModel : ISerializableModel
    {
        public abstract Type BindType { get; }
        public abstract override string ToString();
    }
}


Base64でシリアル化可能なモデルのカスタムモデルバインダを実装します。下記サンプルのように、自身の型のModelMetadataから、ModelValidatorを取得して自身の型のバリデーションの処理も行うように実装しておくと、カスタムモデルバインダでもアノテーション検証がされるようになり、ViewModelに入れ子となっている場合でも検証を有効にするよう実装することもできます。これは、今回の実装にかかわらず様々な実装で使える方法なので覚えておいて損はないでしょう。


SerializeableModelBinder{T}.cs

using System.Web.Mvc;

namespace ModelBinderSample.Models.ModelBinder.Binder
{
    public class SerializeableModelBinder<T> : DefaultModelBinder
    {
        public override object BindModel(ControllerContext controllerContext, ModelBindingContext bindingContext)
        {
            if (bindingContext.ModelMetadata.ModelType != typeof(T))
                return base.BindModel(controllerContext, bindingContext);

            var serializedModel = controllerContext.HttpContext.Request[bindingContext.ModelName];
            var model = Serializer.Deserialize(serializedModel);

            ModelMetadata modelMetadata = ModelMetadataProviders.Current.GetMetadataForType(() => model, model.GetType());
            ModelValidator compositeValidator = ModelValidator.GetModelValidator(modelMetadata, controllerContext);

            foreach (ModelValidationResult result in compositeValidator.Validate(null))
                bindingContext.ModelState.AddModelError(bindingContext.ModelName + "." + result.MemberName, result.Message);      

            return model;
        }
    }
}

Base64のシリアライズとデシリアライズ
Serializer.cs

using System;
using System.IO;
using System.Runtime.Serialization.Formatters.Binary;

namespace ModelBinderSample
{
    public static class Serializer
    {
        public static string Serialize(object obj)
        {
            using (MemoryStream stream = new MemoryStream())
            {
                var bf = new BinaryFormatter();
                bf.Serialize(stream, obj);
                return Convert.ToBase64String(stream.GetBuffer());
            }
        }

        public static object Deserialize(string subject)
        {
            using (var stream = new MemoryStream(Convert.FromBase64String(subject)))
            {
                var bf = new BinaryFormatter();
                return bf.Deserialize(stream);
            }
        }
    }
}

Sample1.cs

using System;
using System.ComponentModel.DataAnnotations;
using System.Diagnostics.Contracts;
using ClassLibrary1;
using ModelBinderSample.Models.ViewModel;

namespace ModelBinderSample.Models
{
    [Serializable]
    public class Sample1 : AbustractSerializableModel
    {
        public override Type BindType
        {
            get { return this.GetType(); }
        }

        [Display(Name="ただのプロパティ")]
        public string NomalProperty { get; set; }

        public string[] ParamString { get; set; }

        public int[] ParamInt { get; set; }

        public Hoge Hoge { get; set; }

        public override string ToString()
        {
            Contract.Ensures(!string.IsNullOrWhiteSpace(Contract.Result<string>()));
            return Serializer.Serialize(this);
        }
    }
}

Sample2.cs

using System;
using System.ComponentModel.DataAnnotations;
using System.Diagnostics.Contracts;
using ClassLibrary1;
using ModelBinderSample.Models.ViewModel;

namespace ModelBinderSample.Models
{
    [Serializable]
    public class Sample2 : AbustractSerializableModel
    {
        public override Type BindType
        {
            get { return this.GetType(); }
        }

        [Display(Name = "必須なプロパティ")]
        [Required(ErrorMessage = "「{0}」は、必須だってばよ！")]
        public string RequiredProperty { get; set; }

        public string[] ParamString { get; set; }

        public int[] ParamInt { get; set; }

        public Hoge Hoge { get; set; }

        public override string ToString()
        {
            Contract.Ensures(!string.IsNullOrWhiteSpace(Contract.Result<string>()));
            return Serializer.Serialize(this);
        }
    }
}


Sample3.cs

using System.ComponentModel.DataAnnotations;
using ModelBinderSample.Models.ViewModel;

namespace ModelBinderSample.Models
{
    public class Sample3 
    {

        [Display(Name = "入力必須なやつ")]
        [Required(ErrorMessage = "「{0}」は、必須だってばよ！")]
        public string RequiredProperty { get; set; }

        public string[] ParamString { get; set; }

        public int[] ParamInt { get; set; }

        public Hoge Hoge { get; set; }
    }
}


モデルバインダの登録

protected void Application_Start()
{
    AreaRegistration.RegisterAllAreas();

    // Add ModelBinder
    ModelBinders.Binders.Add(typeof(Sample1), new SerializeableModelBinder<Sample1>());
    ModelBinders.Binders.Add(typeof(Sample2), new SerializeableModelBinder<Sample2>());
    ModelBinders.Binders.Add(typeof(Sample3), new SerializeableModelBinder<Sample3>());

    RegisterGlobalFilters(GlobalFilters.Filters);
    RegisterRoutes(RouteTable.Routes);
}


Sample3クラスは、SerializableでもなければISerializableModelインターフェイスも実装していないので、SerializeableModelBinderクラスによってバインドされませんが、Base64でシリアライズできるモデルについては、汎用的なモデルバインダによってバインディングされます。ご利用は計画的に。何が言いたいかというと、必ずしもモデルの型とモデルバインダは１対１の関係というわけではないというわけです。また、「モデルの型」という言い方をしていますが、型以外の判定手段（インスタンスそのものの値や状態）でバインディング方法を変えるという方法を取ることもできます。そこは設計次第です。腕の見せ所ですね。


さて、実装サンプルSerializeableModelBinderクラスを用いることで、Base64でシリアライズできるモデルについて汎用的にバインディングできるようになりました。しかしながら、Sample4,Sample5...と新しくシリアライズ可能なクラスを作るたびに、Application_Start()にて、対象となるモデルに対してモデルバインダを登録しなければならないというのは非常に面倒くさいです。われわれ開発者は、自動化できることならなるべく自動化したいという怠け者。



そこで、MEF(Managed Extensibility Framework)を用いて自動拡張型カスタムモデルバインダプロバイダーを作ることを考えてみます。



ExportProviderの拡張 : 任意のインターフェイスの実装をコントラクトとするカスタムエクスポートプロバイダー

さっそく「MEFを用いた自動拡張型カスタムモデルバインダプロバイダー」の作成と行きたいところなんですが、その前に下準備が必要となります。ISerializableModelインターフェイスを実装している具象クラスをコントラクトとするMEFエクスポートが必要になるからです。そのために、任意のインターフェイスの実装をコントラクトとするカスタムエクスポートプロバイダーを作成する必要があります。前回のエントリーではWindows AzureでBlobストレージからMEFのパーツを検索できるカスタムCatalogを紹介しました。今回は、Catalogに比べて、よりピンポイントな条件でエクスポートができる、カスタムエクスポートプロバイダーを紹介します。



MEFの入門記事はわかりやすいものがいくつかありますが、入門よりももう少し踏み込んだ情報はあまりありません。海外記事を含めてもカスタムカタログやカスタムエクスポートプロバイダー等の解説記事や簡単なサンプルは決して多くはありません。MEF(Managed Extensibility Framework)を積極的に使おうと考えた場合、カタログやエクスポートプロバイダーのカスタマイズは必須です。オブジェクト指向なスタイルの開発においては、インターフェイスによる多態は日常茶飯事ですし、任意のインターフェイスの実装をコントラクトとするエクスポートプロバイダーとか、欲しくなるのは自然な流れです。ということで、シンプルなサンプルコードを以下に示します。



InterfaceExportProvider{T}.cs

using System;
using System.Collections.Generic;
using System.ComponentModel.Composition;
using System.ComponentModel.Composition.Hosting;
using System.ComponentModel.Composition.Primitives;
using System.Diagnostics.Contracts;
using System.Linq;
using System.Reflection;
using ClassLibrary1;

namespace ClassLibrary2
{
    public class InterfaceExportProvider<T> : ExportProvider
    {
        private readonly IList<InterfaceExportDefinition> exportDefinitions = new List<InterfaceExportDefinition>();

        public InterfaceExportProvider() : this(() => Assembly.GetExecutingAssembly().GetTypes(), t => true) 
        { 
        }
        public InterfaceExportProvider(Func<Type, bool> predicate) : this(() => Assembly.GetExecutingAssembly().GetTypes(), predicate) 
        {
            Contract.Requires(predicate != null);
        }

        public InterfaceExportProvider(Func<Type[]> factory, Func<Type, bool> predicate)
        {
            Contract.Requires(factory != null);

            var types = factory()
                       .Where(t => !t.IsAbstract)
                       .Where(t => !t.IsInterface)
                       .Where(t => predicate(t));
            ComposeTypes(types);
        }

        protected override IEnumerable<Export> GetExportsCore(ImportDefinition definition, AtomicComposition atomicComposition)
        {
            Contract.Ensures(0 <= this.exportDefinitions.Count);
            return exportDefinitions.Where(ed => definition.ContractName == ed.ContractName)
                                    .Select(ed => new Export(ed, () => Util.New(ed.ServiceType)));
        }

        [ContractInvariantMethod]
        private void ObjectInvariant()
        {
            Contract.Invariant(typeof(T).IsInterface);
        }

        private void ComposeTypes(IEnumerable<Type> serviceTypes)
        {
            Contract.Requires(serviceTypes != null);

            serviceTypes
                .Where(x => !x.IsAbstract)
                .Select(type => new { Type = type, InterfaceType = type.GetInterfaces().Where(t => t == typeof(T)).SingleOrDefault()})
                .Where (x  => x.InterfaceType != null).ToList()
                .ForEach(x =>
                {
                    var metadata = new Dictionary<string, object>();
                    metadata[CompositionConstants.ExportTypeIdentityMetadataName] = AttributedModelServices.GetTypeIdentity(x.Type);
                    var contractName = AttributedModelServices.GetContractName(x.InterfaceType);
                    var exportDefinition = new InterfaceExportDefinition(contractName, metadata, x.Type);
                    exportDefinitions.Add(exportDefinition);
                });
        }
    }
}

例えば上記のクラスをデフォルトコンストラクタでインスタンス化した場合、現在実行中のコードを格納しているアセンブリ内のうち、ジェネリックタイプTで指定したインターフェイスをコントラクトとする型についてエクスポートを行います。そういうExportプロバイダー実装です。要するに、ジェネリックタイプTで指定したインターフェイスを実装している具象クラスを検索してオブジェクトグラフのファクトリを行うようなプロバイダーということです。これがあると、オブジェクト指向プログラミングで当たり前のインターフェイスによる多態をひとまとめに"[ImportMany(typeof(インターフェイス))]"というように、Exportできるので嬉しいというわけです。




上記InterfaceExportProviderクラスに合わせて、そのようなコントラクトを満たすExportオブジェクトを表すカスタムExportDefinitionも定義も必要となります。こちらは、ContractNameプロパティとMetadataプロパティをoverrideして実装を上書いているだけのなんの芸もない実装ですので、難しいことは何もないですね。

InterfaceExportDefinition.cs

using System;
using System.Collections.Generic;
using System.ComponentModel.Composition.Primitives;
using System.Diagnostics.Contracts;

namespace ClassLibrary2
{
    public class InterfaceExportDefinition : ExportDefinition
    {
        private readonly string _contractName;
        private readonly Dictionary<string, object> _metaData;

        public InterfaceExportDefinition(string contractName, Dictionary<string, object> metaData, Type type)
        {
            Contract.Requires(metaData != null);
            Contract.Requires(type != null);
            Contract.Ensures(this._contractName == contractName);
            Contract.Ensures(this._metaData == metaData);

            this._contractName = contractName;
            this._metaData = metaData;
            ServiceType = type;
        }

        public Type ServiceType { get; private set; }

        [ContractInvariantMethod]
        private void ObjectInvariant()
        {
            Contract.Invariant(this._metaData != null);
        }

        public override IDictionary<string, object> Metadata
        {
            get 
            {
                Contract.Ensures(this._metaData != null);
                Contract.Ensures(Contract.Result<IDictionary<string, object>>() == this._metaData);
                return this._metaData; 
            }
        }

        public override string ContractName
        {
            get 
            {
                Contract.Ensures(Contract.Result<string>() == this._contractName);
                return this._contractName; 
            }
        }
    }
}


これで、任意のインターフェイスの実装をコントラクトとするカスタムエクスポートプロバイダーができました。オブジェクト指向においては、インターフェイスによる多態は日常茶飯事ですので利用場面はたくさんありそうですね。


MEFを用いた自動拡張型カスタムモデルバインダプロバイダー

では作成したInterfaceExportProviderクラスを用いて、自動拡張してくれるカスタムモデルバインダプロバイダーを実装します。ImportMany属性で、コントラクト型でISerializableModelを指定することで、ISerializableModelインターフェイスを実装している具象クラスをコントラクトとしたエクスポートがなされるので、ISerializableModelインターフェイスを実装しているモデルについて、適切にモデルバインディングしてくれるという寸法です。CompositionContainerフィールドはIDisposableですので、忘れずにIDisposableのイディオムを用いて綺麗にガベコレしてくれるように実装しましょう。


SerializeableModelBinderProvider.cs

using System;
using System.Collections.Generic;
using System.ComponentModel.Composition;
using System.ComponentModel.Composition.Hosting;
using System.Linq;
using System.Web.Mvc;
using ClassLibrary1;
using ClassLibrary2;
using ModelBinderSample.Models.ModelBinder;
using System.Collections.Concurrent;

namespace ModelBinderSample.Models.ModelBinderProvider
{
    public class SerializeableModelBinderProvider : IModelBinderProvider, IDisposable
    {
        private bool disposed;
        private readonly ConcurrentDictionary<Type, Type> _cache = new ConcurrentDictionary<Type, Type>();

        [ImportMany(typeof(ISerializableModel))]
        private IEnumerable<Lazy<ISerializableModel>> _serializableModels = null;
        private CompositionContainer _Container = null;

        private SerializeableModelBinderProvider()
        {
            this.disposed = false;
        }

        public SerializeableModelBinderProvider(Func<Type[]> factory) : this()
        {
            ComposeParts(factory);
        }

        public IModelBinder GetBinder(Type modelType)
        {
            this.ThrowExceptionIfDisposed();

            if (CanBind(modelType))
            {
                var modelBinderType = _cache.GetOrAdd(modelType, typeof(SerializeableModelBinder<>).MakeGenericType(modelType));
                return (IModelBinder)Activator.CreateInstance(modelBinderType);
            }
            return null;
        }

        public bool CanBind(Type modelType)
        {
            if (_cache.ContainsKey(modelType))
                return true;

            var count = _serializableModels.Where(m => m.Value.BindType == modelType).Count();
            if (count > 0)
                return true;
            return false;
        }

        protected void ThrowExceptionIfDisposed()
        {
            if (this.disposed)
            {
                throw new ObjectDisposedException(this.GetType().ToString());
            }
        }

        public void ComposeParts(Func<Type[]> factory)
        {
            this.ThrowExceptionIfDisposed();

            var provider = new InterfaceExportProvider<ISerializableModel>(factory, x => x.IsSerializable);
            _Container = new CompositionContainer(provider);
            _Container.ComposeParts(this);
        }

        protected virtual void Dispose(bool disposing)
        {
            lock (this)
            {
                if (this.disposed)
                {
                    return;
                }

                this.disposed = true;

                if (disposing)
                {
                    if (_Container != null)
                    {
                        _Container.Dispose();
                        _Container = null;
                    }
                }
            }
        }

        public void Dispose()
        {
            this.Dispose(true);
            GC.SuppressFinalize(this);
        }
    }
}


このような汎用的なカスタムモデルバインダプロバイダーを作成することで、Sample4, Samole5...と、シリアル化可能なクラスを次々と定義していくだけで、自動的に拡張されていくカスタムエクスポートプロバイダーを作成することができるというわけです。MEFはユーザーの目に見えるような機能面での拡張のみならず、開発視点においても確実に設計の幅を広げてくれます。MEFは.NET Framework4標準ですので、臆することなくガンガン使っていけるのがうれしいですね。



IModelBinderProviderインターフェイスがイケてない説

まず、System.Web.Mvc.IModelBinderProviderインターフェイスの定義をご覧いただきましょう。

public interface IModelBinderProvider
{
	IModelBinder GetBinder(Type modelType);
}


モデルの型を引数で受け取り、適切なモデルバインダを返すだけのGetBinderメソッドを持つ、とてもシンプルなインターフェイスです。あまりにもシンプルすぎて、モデルバインダプロバイダーがどんなモデルの型を対象としたプロバイダーなのか外部から知るすべもありません。GetBinderメソッドの戻り値が null だったら、次のモデルバインダプロバイダーに処理を委譲する作りになっているので、複数のカスタムモデルバインダプロバイダーが協調して動作するようにするには、サポートしないモデルの型の場合に必ず null を返さなければなりません。「該当する結果がない場合にnullを返して、戻り値側でそれがnullだったら次の処理を...」という仕様はあんましイクナイ（・Α・）と思います。もっと別の方法もあっただろうに...。




あと、おまけ。
Util.cs

using System;
using System.Linq;
using System.Linq.Expressions;
using System.Reflection;
using System.Web.Mvc;

namespace ClassLibrary1
{
    public static class Util
    {
        public static T New<T>()
        {
            Type type = typeof(T);
            Func<T> method = Expression.Lambda<Func<T>>(Expression.Block(type, new Expression[] { Expression.New(type) })).Compile();
            return method();
        }

        public static object New(Type type)
        {
            Func<object> method = Expression.Lambda<Func<object>>(Expression.Block(type, new Expression[] { Expression.New(type) })).Compile();
            return method();
        }

        public delegate TInstance ObjectActivator<TInstance>(params object[] args);
        public static ObjectActivator<TInstance> GetActivator<TInstance>(ConstructorInfo ctor)
        {
            Type type = ctor.DeclaringType;
            ParameterInfo[] paramsInfo = ctor.GetParameters();

            ParameterExpression param = Expression.Parameter(typeof(object[]), "args");
            Expression[] argsExp = new Expression[paramsInfo.Length];

            for (int i = 0; i < paramsInfo.Length; i++)
            {
                Expression index = Expression.Constant(i);
                Type paramType = paramsInfo[i].ParameterType;
                Expression paramAccessorExp = Expression.ArrayIndex(param, index);
                Expression paramCastExp = Expression.Convert(paramAccessorExp, paramType);
                argsExp[i] = paramCastExp;
            }

            NewExpression newExp = Expression.New(ctor, argsExp);
            LambdaExpression lambda = Expression.Lambda(typeof(ObjectActivator<TInstance>), newExp, param);

            ObjectActivator<TInstance> compiled = (ObjectActivator<TInstance>)lambda.Compile();
            return compiled;
        }
    }
}

モデルバインダプロバイダーの登録

protected void Application_Start()
{
    AreaRegistration.RegisterAllAreas();

    // Add ModelBinderProvider
    ModelBinderProviders.BinderProviders.Add(new SampleViewModel0BinderProvider());
    ModelBinderProviders.BinderProviders.Add(new SerializeableModelBinderProvider(() => Assembly.GetExecutingAssembly().GetTypes()));

    RegisterGlobalFilters(GlobalFilters.Filters);
    RegisterRoutes(RouteTable.Routes);
}


さてコード中心の記事でしたが、ASP.NET MVC3のカスタムモデルバインダとカスタムモデルバインダプロバイダーについてのサンプルプログラムと、MEFのカスタムエクスポートプロバイダーを利用した自動拡張型のコンポーネント設計の手法について見てきました。モデルバインダの仕組みはASP.NET MVC3のコアコンポーネントのひとつであり基本中の基本ですので、既定のDefaultModelBinderのみに頼るのではなく、このあたりの仕組みや拡張・設計ポイントはしっかり押さえておきたいところです。長々と書きましたが、何かの参考になれば幸いです。


F#はちょい充電中。

Windows AzureとMEFで再デプロイを必要としない拡張（または縮小）可能なクラウドアプリケーション。BlobストレージからMEFのパーツを検索できるカスタムカタログ BlobStorageCatalog を作ろう。

プログラミング C# Windows Azure MEF ASP.NET MVC3 Blob Storage

しばらくF#ネタしか書いていませんでした。たまにはC#ネタを置いておきます。
C#ネタというよりは、最近仕事で利用しているWindows AzureとMEFのネタですが。


Managed Extensibility Framework (MEF)とは

Managed Extensibility Framework (MEF) は、.NET Frameworkに最適な拡張可能なアプリケーションを作成するための一連の機能を提供する軽量ライブラリです。既定で提供されているのは属性プログラミングモデルですが、MEFのコアAPIは全く属性に依存していないので、MEFのコアAPIにアクセスする方法を定義したクラスを独自に作成することでリフレクションベースのプログラミングモデルなど、様々なスタイルで利用可能です。




MEFは、.NET Framework 4 およびSilverlight 4で標準利用可能です。なお現在もオープンソースで開発が進められていて、ASP.NET MVC向けのComposition providerなどを含む、MEF 2 Preview 5がCodePlexよりダウンロード可能です。wktkですね。


http://mef.codeplex.com/





「MEFとは、簡単に言うとDIである」というような説明がされがちですが、一般的なIoCコンテナ（DIコンテナ）フレームワークほど多機能ではありません。MEFは、 IoCコンテナ(DIコンテナ)で言うところの、いわゆるオブジェクトグラフのファクトリをメインとして機能します。つまり、実行時に解決する必要があるクラスのメンバーを動的に認識して処理することができます。しかし逆に言うと、一般的なIoCコンテナ（DIコンテナ）フレームワークほど豊富な機能はなく、非常にコンパクトな構成です。MEFにもキャッシュ機能があるのは確かですが、インスタンスのキャッシュを最小限しかサポートしません。また、.NET Framework 4 に同梱されているバージョンのMEF では処理のインターセプト(AOPサポート)の機能がまったくありません。純粋に、IoCコンテナ(DIコンテナ)フレームワークのさまざまな機能を求める場合、MEFでは満足できないでしょう。


では、どのような場合にMEFを利用すれば良いのか。それは、アプリケーションが汎用性のある機能拡張（プラグイン,アドイン）を求めているかどうかです。これに該当する場合はMEFの利用が有効で、そうではない場合は、あえてMEFを利用する意味はあまりないでしょう。


拡張（または縮小）可能なクラウドアプリケーション
「拡張（または縮小）可能なクラウドアプリケーション」などと大風呂敷を広げてみたものの、わたしはWindows AzureのWebRoleとWorkerRoleくらいしかかじったことがありません。ここではWindows Azureにおいて、再デプロイを必要としない拡張可能なWebRole、WorkerRoleを作りたいケースについて考えます。


.NET Frameworkで拡張可能なアプリケーションを作りたい場合、有効な方法としてMEFがあると前述しました。Azureに置いてもそれは同じです。しかし、Azureで一度デプロイしたものについて動的に機能拡張をするにはどのようにしたらよいのでしょう。まっさきに思い浮かぶのが、Blobストレージの利用です。Blobストレージに格納してあるアセンブリを、ローカルストレージにダウンロードして、DirectoryCatalogクラスを利用してパーツをExportする方法が考えられます。しかしその方法では、対象のアセンブリについてプロセスが掴んでしまうため、デプロイ済みのサービスについて、動的に動作を拡張 or 変更するということができません。ではどうするか。その場合、ローカルストレージは利用せず、BlobストレージからダウンロードしたアセンブリをAssemblyCatalogクラスを利用して直接パーツをExprotする方法を取るとうまくいきます。でも、これをいちいちプログラミングするのは非常に面倒くさいです。常識的に考えて部品化ですね。Blobストレージ内のアセンブリからMEFのパーツを検索できる専用のカタログクラスであるところの、BlobStorageCatalogとか作っちゃえばいいと思います。



以下、実装サンプルです。


BlobStorageCatalog.cs

using System;
using System.Collections.Generic;
using System.ComponentModel.Composition.Hosting;
using System.ComponentModel.Composition.Primitives;
using System.Diagnostics.Contracts;
using System.Globalization;
using System.IO;
using System.Linq;
using System.Reflection;
using System.Threading;
using Microsoft.WindowsAzure;
using Microsoft.WindowsAzure.StorageClient;

namespace ClassLibrary2
{
    public class BlobStorageCatalog : ComposablePartCatalog, ICompositionElement
    {
        private readonly object _thisLock = new object();
        private readonly CloudStorageAccount _account = null;
        private readonly static Dictionary<string, byte[]> _dicAssembly = new Dictionary<string, byte[]>();

        public string ContainerName { get; private set; }
        public string BlobName { get; private set; }
        private AssemblyCatalog _innerCatalog = null;
        private int _isDisposed = 0;

        protected BlobStorageCatalog() {}

        public BlobStorageCatalog(CloudStorageAccount account, string containerName, string blobName) : this()
        {
            Contract.Requires(account != null);
            Contract.Requires(!String.IsNullOrWhiteSpace(containerName));
            Contract.Requires(!String.IsNullOrWhiteSpace(blobName));
            Contract.Requires(containerName == containerName.ToLower());

            this._account = account;
            this.ContainerName = containerName;
            this.BlobName = blobName;
        }

        private ComposablePartCatalog InnerCatalog
        {
            get
            {
                this.ThrowIfDisposed();
                lock (this._thisLock)
                {
                    if (_innerCatalog == null)
                    {
                        var catalog = new AssemblyCatalog(LoadAssembly(this._account, this.ContainerName, this.BlobName));
                        Thread.MemoryBarrier();
                        this._innerCatalog = catalog;
                    }
                }
                return _innerCatalog;
            }
        }

        public override IEnumerable<Tuple<ComposablePartDefinition, ExportDefinition>> GetExports(ImportDefinition definition)
        {
            return this.InnerCatalog.GetExports(definition);
        }

        public override IQueryable<ComposablePartDefinition> Parts
        {
            get { return this.InnerCatalog.Parts; }
        }

        private string GetDisplayName()
        {
            return string.Format(CultureInfo.CurrentCulture,
                                "{0} (BlobStorage: ContainerName=\"{1}\", BlobName=\"{2}\") (Assembly=\"{3}\")", 
                                GetType().Name,
                                this.ContainerName,
                                this.BlobName,
                                _innerCatalog.Assembly.FullName);
        }

        public override string ToString()
        {
            return GetDisplayName();
        }

        private void ThrowIfDisposed()
        {
            if (this._isDisposed == 1)
            {
                if (this == null)
                    throw new NullReferenceException(this.GetType().Name);
                throw new ObjectDisposedException(this.GetType().ToString());
            }
        }

        protected override void Dispose(bool disposing)
        {
            try
            {
                if (Interlocked.CompareExchange(ref this._isDisposed, 1, 0) == 0)
                {
                    if (disposing)
                    {
                        if (this._innerCatalog != null)
                        {
                            this._innerCatalog.Dispose();
                        }
                    }
                }
            }
            finally
            {
                base.Dispose(disposing);
            }
        }

        string ICompositionElement.DisplayName
        {
            get { return GetDisplayName(); }
        }

        ICompositionElement ICompositionElement.Origin
        {
            get { return null; }
        }

        private static Assembly LoadAssembly(CloudStorageAccount account, string containerName, string blobname)
        {
            var blobStorage = account.CreateCloudBlobClient();
            var container = blobStorage.GetContainerReference(containerName);

            var blob = container.GetBlobReference(blobname);
            var blobUri = container.Uri + "/" + blobname;

            using (var strm = new MemoryStream())
            {
                blob.DownloadToStream(strm);
                byte[] asseblyBytes = strm.ToArray();
                
                if (!_dicAssembly.ContainsKey(blobUri))
                {
                    _dicAssembly.Add(blobUri, asseblyBytes);
                    return Assembly.Load(asseblyBytes);
                }
                if (Enumerable.SequenceEqual(asseblyBytes, _dicAssembly[blobUri]))
                {
                    return Assembly.Load(_dicAssembly[blobUri]);
                }

                _dicAssembly[blobUri] = asseblyBytes;
                return Assembly.Load(asseblyBytes);
            }
        }
    }
}


だいたいこんな感じですかね。特に問題はないと思いますが、厳密な検証はしていません。実戦投入は計画的に。


拡張（または縮小）可能なWinedow　Azure上で動くASP.NET MVC3　Webアプリケーションのサンプル


MEFで拡張可能な計算アプリケーション作成用のインターフェイスを定義

namespace ClassLibrary1
{
    public interface ICalculator
    {
        IEnumerable<char> Symbols { get; }
        string Calculate(int left, int right, char operation);
    }

    public interface IOperation
    {
        int Operate(int left, int right);
    }

    public interface IOperationData
    {
        Char Symbol { get; }
    }

}


足し算と引き算を定義

namespace Calculator
{

    [Export(typeof(IOperation))]
    [ExportMetadata("Symbol", '-')]
    class Subtract : IOperation
    {
        public int Operate(int left, int right)
        {
            return left - right;
        }
    }

    [Export(typeof(IOperation))]
    [ExportMetadata("Symbol", '+')]
    class Add : IOperation
    {
        public int Operate(int left, int right)
        {
            return left + right;
        }
    }
}


足し算と引き算が利用可能





掛け算を新たに定義してビルドし、Calculator.dllを作る

    [Export(typeof(IOperation))]
    [ExportMetadata("Symbol", '*')]
    public class Multiply : IOperation
    {
        public int Operate(int left, int right)
        {
            return left * right;
        }
    }


Calculator.dllをアップロード


ページを再度読み込みなおすと、拡張した掛け算部分が追加されて利用可能に。


という具合に、MEFを利用することで、再度デプロイしなおさなくても、拡張（または縮小）可能なWindows Azureアプリケーションを設計することができます。



このように、MEF は .NET Framework の拡張（または縮小）可能なアプリケーションを構築する際にとても便利なソリューションですが、このとき最も難しい部分は、拡張できるようにアプリケーションを設計することです。これは拡張可能アプリケーション設計そのもの難しさであって、MEFテクノロジそのものが難しいわけではありません。上記のサンプルでは拡張性の乏しい単純な構造の設計となっていますが、より汎用的な拡張が必要なアプリケーションを設計する場合、一気に複雑になります。MEFで提供されているAPIを十分理解した上で、適切な拡張ポイントを見つけ出して、それを将来を見据えたかたちでどれだけ汎用的に拡張できるよう設計できるかがポイントとなってきます。このような設計では、オブジェクト指向の考え方が重要になるでしょう。



ここでは省略しますが、もちろんF#でも同様のアプリケーションを書くことが可能です。
ただF#でMEFを利用する場合はちょっと癖があるんですけどね。でもそれはまた別のお話。


拡張可能なWinedow　Azure上で動くASP.NET MVC3　WebアプリケーションのサンプルプログラムをSkyDriveにアップしておきます。
SkyDrive - Azure+MEF.zip

F# Implementation of BackPropagation Neural Network for Pattern Recognition(LifeGame)

プログラミング F#2.0 F# 機械学習 アルゴリズム ニューラルネットワーク XNA HLSL 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

プログラミング F#2.0 F#

元ネタ
パケットの送受信量 (C#)(F#) - SIN@SAPPOROWORKSの覚書
http://d.hatena.ne.jp/spw0022/20111116/1321437712


確かに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



様々な角度から 物事を見ても、自分を見失わずにありたい。



補足
いくつか Seq.initInfinite 関係のツイートを拾ってみました。


ということで、Seq.initInfiniteのご利用は計画的に。