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

Ｍが如くF#ive　夢、叶えしMono

プログラミング F#3.0 F# Mono MonoGame MonoDevelop Windows8 Mac Verlet法 XNA

この記事は、F# Advent Calendar 2012 の12日目です。ひとつ前の記事は@katayama_kさんの「スキャナが出力したPDFを、出力デバイスに合わせて変換しよう-F#マスターへの道」です。ありがたいことにソースコードを公開してくださっているので、iTextSharpを使ってPDFを扱いたい場合に参考になりそうです。








龍が如く５、NewスーパーマリオブラザーズU、などプレイしたいゲームが盛りだくさんだけど、ぜんぜんやる時間が取れない今日この頃ですが、みなさんいかがお過ごしでしょうか。
この記事では、F# と MonoGame でゲームを作ろう(Mac編)という話題を扱います。F#をゲーム制作に実用してみようという話です。関数型楽しい。ゲーム作るの楽しい。ならば組み合わせない手はない！ いわゆるひとつの「カツカレー理論」を採用しましたが、あなたを満足させられるような 実用 や F# の 成分は少ないかもしれません。




私がはじめて関数型言語に触れたのは５年近く前で、言語は Haskell でした。まだ関数型について右も左もわからなかった頃、Webで偶然見つけた Haskell で書かれた テトリスクローンに心が躍り、Haskellで書かれたグラディウスクローン「Monadius」 に衝撃を受けた。「いつか俺も関数型言語でなんかゲーム作る」と胸が熱くなったのを今でもよく覚えています。関数型言語は、Webアプリケーションを開発できる程度には実用です。ゲームを作れる程度には実用です。正味な話だいたいなんでも作れます。ジョジョに人気も高まってきているせいか、Scala や F# などで実際にゲームを作って楽しんでいる人も少しずつ増えてきているようです。歩みは遅くとも流れは来ている。そう感じます。ひとむかし前と比べて、スマホやタブレットPCが一般層にまで浸透してきた今、個人で作ったゲームでも手軽に大きなマーケットに公開できるインフラも整ってきました。もしあなたがお気に入りのプログラミング言語でゲームを作れたら。それってとっても実用だなって。



MonoGameとは

MonoGame は一言で言うと XNA4.0 のオープンソース実装です。XNAは、Windows、Xbox 360、Windows Phone向けのゲームを作ることができるマルチプラットフォーム(ただしマイクロソフト系に限る)に対応のイケているフレームワークです。実際に利用してみるとすぐにわかりますが、初心者でも手軽にゲームを作ることができるように考えられて設計されています。もちろん、初心者のみをターゲットにしているものではなく、上級者なら高度な技術力をいかんなく発揮することもできます。C#、VB、F#など、いずれかの .NETの言語さえ知っていれば、すぐにゲームプログラミングに取り組める環境が整っています。実際、ゲームプログラミングもXNAも素人な私ですが、特にハマることもなくゲームを作ることができました。「とことんF#よぷよ！」は、スーパーファミコンぷよぷよ通のとことんぷよぷよモード相当のもので、F# で書いた私のXNA処女作です。


そんなかわいい XNA ですが、 Windows8 では XNA はサポート対象外となってしまいました。この決定に、多くの XNA ゲーム開発者が涙したことは言うまでもありません。そこで救いの手を差し伸べるのが、オープンソースのゲーム開発フレームワーク MonoGame です。


MonoGameは、内部的にはOpenGLベースでの総書き換えなので、Windowsに限らずともさまざまなOS上で動作します。前身は XNA で開発されたゲームを iOS 上で動作させる目的で開発されていた XNATouch でした。@smallgeek さんが紹介してくださった、Mono for Android のお仲間です（Mono for Android と F# - FsNinja）。現在では Android、iOS、Mac OS X、Linux 。そして Windows 8 ストア向けゲームの開発も可能になりました。また、今後 PlayStation Mobile をサポートする予定があり、鋭意開発中とのことです。「PSVita で F# が動くぞ...!！」が来る日も近い？ 胸が熱くなる。


MonoGame のここがいいね！

MonoGame の素晴らしい点は、なにより XNA4.0 で使用するのと全く同じ名前空間を使用していることです。これにより、XNA の API が完全に保たれていてます。2Dのみでなく、部分的ではあるものの3Dのサポートもされているので、理論的には XNAで書かれたプログラムを参照設定の変更や各プラットフォームに依存するゲーム起動部分(Gameクラスの起動）などに関するわずかな変更を加えるだけで、異なるプラットフォームに簡単に移植することができます。WOPE (Write Once, Play Everywhere) 「一度書けば、どこでも動く」 の御旗のもとに開発されている MonoGame を利用することで、初心者でも手軽にクロスプラットフォームに対応したゲームを作ることができます。.NET Framework や XNA の知識や経験をそのまま使えるという恩恵を受けながら、あらゆるプラットフォーム（市場）に対してゲームを発信することができます。MonoGame には、 iOS や Android 向けのハイクオリティなゲームが開発（あるいはXNAからの移植）されているという実績があり、十分にその有用性が確認できます。 また、MonoDevelop はもちろん、 Visual Studio での開発もサポートされています。XNA あるいは .NET開発者にとって、最も注目すべきゲーム開発フレームワークのひとつと言えるでしょう。



この記事を書いたきっかけ

MonoGame の F# テンプレートの作者である@7sharp9氏のツイートおよびブログの記事を見たのがきっかけです。素敵な記事を書いてくださっています。感謝。


F# and MonoGame on the Mac
http://7sharpnine.com/posts/Fsharp-and-MonoGame-on-the-Mac/
現在は、簡単に導入ができるアドインが提供されているので、この記事の内容は古いものになってしまっていますが、
MonoGameのF#テンプレートの導入方法について書かれています。初めて利用するときに参考にさせていただきました。


MonoGame 3D Basics
http://7sharpnine.com/posts/monogame-3d-basics/
正四面体の描画方法について解説されています。



とりあえず MonoGame を使ってみる (Windows8編)



Windows環境では、MonoGameインストーラをダウンロードして、インストールします。すると、Visual Studio 向けの MonoGameのプロジェクトテンプレート(C#用)が追加されますので、それで開発することができます。「えっ？F#のテンプレートはないのかい？」まだありません。XNA4.0同様にF#向けのテンプレートは用意されていませんが、デスクトップゲームであれば、 XNA4.0 と同じ要領で 各MonoGame FrameworkのDLLを参照設定してWindows アプリケーションとして作成することで F# でMonoGameを利用したゲームを作れます。動画は以前私が F# + XNA4.0で作ったものを F# + MonoGameへ移植したものです。ソースコードの修正を必要とせず動作しました。MonoGameは Windows8 ストア向けのゲーム開発もサポートしています。しかし、 F# で開発することはできません(2012/12/12現在)。



例の非常に残念な画像



F# で作れる部分はあくまで Portable Class Library（F#では Portable Library）のみに限られるので、MonoGame に依存する部分は F#で書く事はできません（くやしいです！）。MonoGame のAPI に合わせたインターフェイスを Portable Library に定義して１つ被せてラップすることで、依存部分のみ C# に委譲して F# で書ける部分を増やすように作ることも可能ですが、非常に面倒くさい作業になりますし、正直やってられないので現実的な方法ではないでしょう。Portable Library で書けない部分は、素直に C# に頼りましょう。ちなみに「とことんF#よぷよ！」の例で言うと、MonoGame（XNA）に依存しない　namespace PuyoPuyoLibrary(PuyoPuyo.fs) (ソースコードがある記事)の部分を Portable Libraryとして利用することができます。





なお、VMWare (5.0.1)上のWindows8でも動作しましたが、VMWareではGPUやドライバーに大きく影響されてしまいますので、環境によっては SpriteFontがうまく描画されないようです。




XNA4.0 から MonoGameへ　「とことんF#よぷよ！」の移植


非常に退屈な動画




この動画は、F#とXNAで動作していたゲームを MonoGame を使って Mac OS X上で動くように移植する様子を録画したものです。（一部、端折ってます）。開発環境を整えるところが大半で移植作業というほどの手間はなく、ソースコードの変更はごくごくわずかです。 F#とXNAで作ったゲームがこうも簡単に Mac で動いてしまったのには、感動しました。「Mac でも、Monoがあるからできるよ！」と聞いて 「それ知ってます！」とは答えることはできたものの、実際やってみるまであまりピンときませんでした。今回こうして 自分で書いたものが 実際に Mac で動くのを目の当たりにすると、なんだかとっても気分が良いものです。自分は特に何もしていないんですが、なぜか悦に浸れますｗ



Mono も MonoDevelop も MonoGameもすばらしいね！



F# と MonoGame のゲーム開発環境構築について補足

非常に退屈な動画をご覧いただけたのなら、ほぼ説明は必要ないかもしれませんが、Macでの F# + MonoGame の開発環境の構築について補足情報を書いておきます。


インストール前の下準備
なにかしらの Mac を用意します（仮想環境でもよい）。


■Xcode をダウンロードします（無料）
https://developer.apple.com/jp/technologies/tools/
最新のものを取得するとよいでしょう。



せっかくなので、Macの開発者登録もしておくとよいかも（無料）



■MonoDevelopをダウンロードします（無料）


http://monodevelop.com/Download


MonoDevelop 3.0.5(安定版）　MonoDevelop 3.0.5 installer (Mac OS X)　をダウンロードします
MonoDevelop 3.0.6(Beta)でもよいです。



■ Mono Framework をダウンロードします(無料)


http://www.go-mono.com/mono-downloads/download.html


Mono + GTK#　Beta Version: 3.0.2 (Mac OS X)　
Mono MRE installer および Mono MDK installer をダウンロードします



■MonoGameのソースコード を GitHub から取得します（無料)
https://github.com/mono/MonoGame
この工程はもしかするとなくすことができるのかもしれません。



インストールの手順

■Xcodeをインストールします
動画では省略した部分です。
ただダブルクリックしてもマシンにはインストールされませんので、アプリケーションフォルダにコピーしましょう。
Windowsと勝手が違うので、Mac 初心者のわたしは最初よくわかりませんでしたよ。



■Mono Frameworkをインストールします。
Mono MRE 3.0.2 installer と Mono MDK 3.0.2 installer をそれぞれインストールします。
動画のとおりです。



つい最近 バージョン3.0.2が出たので、ワンステップでF#をインストールできるようになりました（いいね！）。


バージョン 3.0.1までは、F#がバンドルされていなかったので、
GitHub から fsharpのソースコードを取得してきて、home brewを入れたりターミナルからのコマンド操作でビルドをするという、ちょっとした工程が必要でしたが、
3.0.2からは、F#3.0 がMonoに標準装備されたので、本当にお手軽に MonoのF#の環境を作れるようになりました。ま、おかげで動画作り直しだったわけですが。



■MonoDevelop を インストールします。
動画のとおりです。ドラッグアンドドロップしましょう。


■F# アドインを追加します。
動画のとおりです。ワンクリックでバインディングできます。


■MonoGame テンプレートアドインを追加します。
動画のとおりです。こちらのURLをコピーして(http://www.infinitespace-studios.co.uk/monodevelop/main.mrep)アドインを追加しましょう。
これで F#の MonoGameプロジェクトテンプレートが利用できます。

こちらも、わたしがMonoGameを触り始めた11月中ごろにはまだなくて、F#のMonoGameテンプレートを利用するにはちょっとした工程が必要でした。先ほどもご紹介しましたが、テンプレートの作者である @7sharp9 氏の記事で解説されてる内容を実行する必要がありました(F# and MonoGame on the Mac)。動画を見ていただけるとわかりますが、実際にテンプレートを開いてみると、バインディングがうまくいっていないように見えます。わたしの環境の問題でしょうか。直接的な解決策ではありませんが、GitHubから取得した MonoGameのMacOS向けのソリューションを、xbuildでビルドしたものを、直接参照設定することで、MonoGameを利用することができるようになります。


これでF#でMonoGameを使ってゲームプログラミングができます。




準備は整った！さぁShow Timeだ


「F# と MonoGame でゲームが作れるって言われてもさ。 そもそもゲームなんて作ったことないし、何から始めたらよいかわからん。」



ですよねー。最初はだれでもそうです。でもよく考えてみてください。そもそも仕事などで作る業務アプリケーションやWebアプリケーション。基幹システムや組み込み開発など、どんなプログラムだって初めは「作ったことのないもの」ばかりのはずです。作ったことのないものを作る楽しさ。みなさんなら知っていますよね？ わたしもゲームを作るのは素人で趣味の域を脱していませんので偉そうなことは言えませんが、やってみると楽しいのでぜひ手を動かしてみてください。



はじめてゲームを作るときは、まずは真似から始めることをおすすめします。アマチュアバンドが、好きなバンドの曲をコピーするのと同じように、それはとてもよい練習です。まずは真似から始めて、慣れてきたら自分たちでちょっとアレンジする、ゆくゆくはオリジナルもやってみたいね！みたいなね。プログラミングを楽しく上達することができます。何事もまずは真似からじゃないでしょうか。「落ちものパズルゲーム」は比較的簡単に作れるので、テトリスクローンは、しばしば練習題材に使われます。「いや俺が作りたいのはね、よくあるオーソドックスな横スクロールのアクションゲームなんだけど。その手のやつのサンプルないの？」ないこともないですが、言語を限定しないとしても、参考にできそうなものは少ないでしょう。「C#で欲しい」と言われると更に減りますし、F# でとなると非常に限定されます。




MonoGameゲームプログラミングの基本（というかXNAと同じ！）

MonoGame はすべてのAPI が XNA4.0 と一致するので、XNA と全く同じ感覚でゲームプログラミングができます。基本は、Gameクラスを継承したゲームを起動するためのクラスを作成し、必要な処理について、メソッドを適宜オーバーライドして実装します。各コンテンツを読み込んだり(LoadContent)、ゲームの状態を更新したり(Update)、描画(Draw)をする処理を書く、それがはじめの一歩です。



namespace MgaGotoku
open MonoMac.AppKit
open MonoMac.Foundation
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

/// Ｍが如く
type MgaGotokuGame () as this = 
  inherit Game()
  /// ゲームタイトル、グラフィックデバイスマネージャ、スプライトバッチ
  let gametitle, gmanager, sprite = "Ｍが如く", new GraphicsDeviceManager(this), lazy new SpriteBatch(this.GraphicsDevice)
  
  /// サンドを鳴らす
  let soundPlay (se:Lazy<SoundEffectInstance>) = se.Force().Play()
  
  /// デフォルトコンストラクタ
  do 
    // Windowの横幅
    gmanager.PreferredBackBufferWidth <- 800
    // Windowの縦幅
    gmanager.PreferredBackBufferHeight <- 480
    ()

  /// ゲームが実行開始する前に必要な初期化処理をここに書きます。
  /// ここで必要なサービスを照会して、関連するグラフィック以外のコンテンツを読む込めます。
  override this.Initialize() =
    base.Window.Title <-gametitle;
    base.Initialize()

  /// LoadContentはゲームごとに１回呼び出されます。
  /// 基本的には、ここですべてのコンテンツを読み込みます。
  override this.LoadContent() =
    base.LoadContent()

  /// UnloadContentはゲームごとに１回呼び出されます。
  /// ここですべてのコンテンツをアンロードします。
  override this.UnloadContent () = 
    base.UnloadContent()

  /// ゲームの状態の更新処理をここに書きます。
  /// プレイヤーの入力判定、キャラクタの衝突判定、オーディオの再生などなど
  override this.Update(gameTime) = 
    base.Update gameTime

  /// ゲームの描画処理をここに書きます
  /// gameTimeは、ゲームの瞬間的なタイミング情報です。
  override this.Draw(gameTime) = base.Draw gameTime |> fun _ ->
    gmanager.GraphicsDevice.Clear(Color.CornflowerBlue)
    sprite.Force().Begin ()
    // Texture2Dであれば、ここでスプライトバッチを描画します。
    sprite.Force().End ()

  /// 終了時の処理をここに書きます。
  override this.EndRun () = base.EndRun(); 

type AppDelegate() = 
    inherit NSApplicationDelegate()
    
    override x.FinishedLaunching(notification) =
        let game = new MgaGotokuGame()
        game.Run()
    
    override x.ApplicationShouldTerminateAfterLastWindowClosed(sender) =
        true
 
module main =         
    [<EntryPoint>]
    let main args =
        NSApplication.Init ()
        using (new NSAutoreleasePool()) (fun n -> 
            NSApplication.SharedApplication.Delegate <- new AppDelegate()
            NSApplication.Main(args) )
        0


ここからジョジョに肉付けをしていきます。プレイヤーの入力（キーボード、ゲームパッド、タッチ操作など）も簡単に取得できますので、プレイヤーの操作に合わせて2Dの画像を上下左右に動かせるようにしてみましょう。そして、SoungクラスやSoundEffectクラスを使うと*.wavや*.mp3などの音を簡単に鳴らせるので、お気に入りの曲を鳴らしてみましょう。なんだかゲームが作れそうな気になってきます！





Ｍが如くF#ive 夢、叶えしMono

ここからは、おまけです。


さて、そろそろ寒〜い記事のタイトルについて触れなければならない。
「また、くだらないこと考えて...」ご名答である。でも思いついちゃったんだからしょうがない。
これを書くきっかけを与えてくれた（？）のは @gab_km さんである。

Mが如くF#ive　夢、叶えしMono





うん。龍が如くは無理。知ってます！ 無理だとわかっていて言っていますね？いじわるだねッ☆　無理なものは無理なんだけど、できることもあるんじゃないかと思って考えた。古き良き王道横スクロールアクション的なアレなら今からでも間に合うもしれない。上記のやり取りで何か悪い電波を受信してしまいました。人に強制されるのは嫌いだけど、自分で思いつちゃったらこれはもうしょうがない。やるしかない。



WiiU でも新しいやつがでたばかりですが、全世界で人気の王道横スクロールアクションゲームは多くの人がそのクローンを作ろうと試みています。YouTube等の動画サイトで 「Mario C#」とか「Mario XNA」あたりで検索をすると、XNAで作ろうとしたクローンの動画がたくさんでてくる。JavaScriptで実装してみた話とかが割と有名でしょうか。私もパズルゲームやシューティングゲームは趣味でいくつか作った経験があるのだけど、アクションゲームは作ったことがなかった。時間もなかったのでそれっぽいものができるかどうか微妙なところでしたが、なんとなくそれっぽい動き(Ｍが如く)になりました。ぜんぜん全くF#である必要性もないし、どちらかというと「それC#で」が求められている感がある。だが、F#で書いた。この誰にも求められていない感が良いね。「龍が如く５」と、「New スーパーマリオブラザーズ U」の誘惑に負けそうになりながらも、我慢して書きました。全然時間がなくてコードをきれいに書いている余裕がなかったので質は非常にアレですが、コメントは多めに書きましたので、どうか生温かい目で見てください。加えて、「〇〇をF#で書いてみた」的なネタ記事はもっと増えてもいいと思っている。別に屁理屈を言ったり言い訳をするつもりは毛頭ないけど、そういうのも逆説的に"実用"なのではないのかなって。



マリオの動きを真似る

実際にやってみて改めてわかったんですが、マリオの動きや操作感はむかしから非常によく練られていたということ。操作していて楽しいようによく考えて作られている。勉強になるなあ。





Mario.fs

namespace MarioLibrary
open System
open System.Collections.Generic
open System.Text
open Microsoft.Xna.Framework.Content
open Microsoft.Xna.Framework.Graphics
open Microsoft.Xna.Framework
open Microsoft.Xna.Framework.Audio

[<AutoOpen>]
module MarioLibrary =
  type Direction = Left | Right         // キャラの向き
  type Motion = Stop | Run | Break      // 停止、移動、ブレーキ
  type State = Stand | Squat            // 立ち、しゃがみ
  type CollisionType = Head | Foot | No // Y軸の当たり判定タイプ：頭、足、なし

  // 幅、立ち状態の高さ、しゃがみ状態の高さ
  let characterWidth, standHeight, squatHeight  = 32, 52, 36
   
  /// ヒゲの配管工
  [<AllowNullLiteral>]
  type Mario internal () = 
    member val Game : Game = null with get,set  // ゲームメイン
    member val X = 0. with get,set              // キャラクタのX座標を取得または設定します。
    member val Y = 0. with get,set              // キャラクタのY座標を取得または設定します。
    member val YPrev = 0. with get,set          // キャラの前回のY座標を保持
    member val Direction = Right with get,set   // キャラの方向
    member val HeadBlock = false with get,set   // 頭にぶつかったか否かを取得または設定します。
    member val Condition = Stand with get,set   // 立ち、しゃがみの状態を取得または設定します。
    member val State = Stop with get,set        // キャラの動作状態
    member val Jumping = false with get,set     // ジャンプ中か否かを取得または設定します。
    member val Air = false with get,set         // キャラクタが空中にいるか否かを取得または設定します。
    member val Jumpval = 0. with get,set        // Verlet法の加算値
    member val Dash = false with get,set        // ダッシュ状態か否か
    member val JumpUp = false with get,set      // 上昇か落下かどうか
    member val LeverVX = 0. with get,set        // 方向キーによる加速度
    member val DashVX = 0. with get,set         // ダッシュによる加速度
    member val AddjumpCnt = 0 with get,set      // Verlet法の加算カウンタ
    member val Jumpadded = 0 with get,set       // Verlet法上昇下降カウンタ
    member val Timer = 0. with get,set          // アニメーション用のタイマー
    member val Blocks = Seq.empty<Rectangle> with get,set // 当たり判定対象のブロックを取得または設定します。

  /// マリオをつくる
  let createMario x y game = new Mario(X = x, Y =y, YPrev = y, Game = game, Direction = Right, State = Stop, Condition = Stand)

  // ダッシュによる最大速度、ダッシュによる加速度、歩行による最大速度、歩行による加速度
  let dashMaxSpeed, dashAcceleration, leverMaxSpeed, leverAcceleration = 6.5, 0.08, 5.5, 0.08

  /// Verlet法の加算値。値を変更でジャンプの放物線を調整
  let verletArr = [ 1.0; 0.5; 0.5; 0.5; 0.5; 0.5; 0.25; 0.25; 0.25; 0.25; 0.25; 0.25; 0.15;]

  // 歩行アニメーション用のベースフレーム、FPS
  let baseFreamRight, baseFreamLeft, fps = 55., -55., 60.

  /// スペースキーを押し続けた場合の加算の割合
  let jumpAddSep = Math.Max(Math.Round((fps |> decimal) / 5m, 1), 1m)

  /// 1メートルを何ピクセルとするか
  let mppx = 34.

  /// 重力加速度
  let gravity = 9.8 * mppx

  /// 重力加速度 × フレーム表示間隔(秒)の2乗
  let gh2 = Convert.ToSingle(gravity * Math.Pow((1. / fps), 2.))

  /// キャラクタテクスチャ幅を取得します
  let width = characterWidth

  /// 移動アニメフレーム
  let mutable moveFrame = 0

  /// キャラクタテクスチャ高さを取得します
  let height (m:Mario) = m.Condition |> function 
    | Squat -> squatHeight 
    | Stand -> standHeight

  /// 現在のキャラクタのX軸における加速度を取得します。
  let getAcceleration (m:Mario) = m.DashVX + m.LeverVX      

  /// 初速度を取得します
  let getV (m:Mario) = 
    let peakY = m.Y - float (standHeight * 3)
    -1. * Math.Sqrt(2. * gravity * (m.Y - peakY))

  /// キャラの座標を表すRectangleを返します
  let posRect (m:Mario) px py = m.Condition |> function
    | Stand -> Rectangle (px, py, characterWidth, standHeight)
    | Squat -> Rectangle (px, py + 16, characterWidth, squatHeight)

  /// ジャンプ音、頭ぶつけた時の音の遅延ロード用
  let se (m:Mario)  = 
    let jumpSuper, bump = ["jump-super";"bump";] |> List.map (fun name -> m.Game.Content.Load<SoundEffect>(@"Content\sound\" + name).CreateInstance() |> fun x -> x.Volume <- 1.0f; lazy x) |> function 
      | a::b::[] -> a,b | _ -> invalidArg "tlist" "リストの長さが違うよ。"
    jumpSuper, bump

  /// Y軸　キャラクタと障害物の当たり判定
  let collisionY (m:Mario) (nextY:float) bumpPlay =
    let px, py = m.X |> int, (Math.Ceiling(nextY)) |> int
    let prec = posRect m px py

    let normalAction () = m.Air <- true
    let normal = normalAction () ; false, float py
    let footAction () = m.HeadBlock <- false; m.Air <- false
    let headAction () = 
      if bumpPlay then
        se m |> snd |> fun bump -> bump.Force().Play()
      m.HeadBlock <- true

    let f (brec:Rectangle) =  
      if prec.Intersects(brec) then
        // 空中
        m.Air <- true
        // 頭の衝突
        if ((prec.Top < brec.Bottom || prec.Top < brec.Bottom) && prec.Bottom > brec.Bottom) then
          true, brec.Bottom |> float, Head 
        // 足の衝突
        elif ((prec.Bottom > brec.Top || prec.Bottom > brec.Top) && prec.Top < brec.Top) then
          true, (brec.Top - standHeight) |> float, Foot
        else
          false, float py, No
      else
        false, float py, No

    if m.Blocks = null || m.Blocks |> Seq.length = 0 then
      false, nextY
    else
      m.Blocks |> Seq.map f
      |> Seq.tryFind(fun (x,_,_) -> x) 
      |> function
      | None -> normal
      | Some (r,y,c) -> c |> function
      | Head -> headAction(); r,y
      | Foot -> footAction(); r,y
      | No   -> normalAction(); r,y

  /// ジャンプ
  let jump (m:Mario) = 
    let px, py = m.X |> int, m.Y - 17. |> int
    let prec = Rectangle(px, py, width, m |> height)
    let result,_ = collisionY m (prec.Y |> float) true
    let jumpSuper, bump = se m
    if result then
      bump.Force().Play()
    else
      jumpSuper.Force().Play()
      m.JumpUp <- true
      m.Jumping <- true

  /// Verlet法で次のY座標を取得する
  let calcVerlet (m:Mario) = 
    let f () = 
      // キャラクターの次のY座標をVerlet法で算出
      let possibleY = 
        if m.Jumping && m.Y = m.YPrev then
          // 初速度から算出
          gravity / (Convert.ToDouble(2. * Math.Pow(fps, 2.))) + getV m  / fps + m.Y 
        else
          // 現在の加速値から算出
          m.Y + m.Y - m.YPrev + m.Jumpval

      // Y座標の当たり判定を行う
      let result, backY = collisionY m possibleY true
      m.YPrev <- m.Y //tempY
      if result |> not then
        possibleY
      else
        m.JumpUp <- false
        m.AddjumpCnt <- 0
        m.Jumpadded <- 0
        m.Jumping <- false
        backY

    if m.JumpUp then
      // 上昇中
      verletArr |> List.map (fun x -> x * -1.) |> fun varray ->
      if m.AddjumpCnt > 0 then
        m.Jumpadded <- m.Jumpadded + 1
        if (m.Jumpadded >= Seq.length varray) then
          // 最後の加算。これ以上キーを押し続けても加算しない
          m.Jumpval <- varray.[Seq.length varray - 1]
          m.AddjumpCnt <- 0
          m.JumpUp <- false
        else
          m.Jumpval <- varray.[m.Jumpadded - 1]
      m.AddjumpCnt <- m.AddjumpCnt + 1
      f ()
    else
      // 落下中
      m.JumpUp <- false
      m.AddjumpCnt <- 0
      m.Jumpadded <- m.Jumpadded + 1
      verletArr |> List.rev |> fun varray -> 
      if m.Jumpadded >= Seq.length varray then
        m.Jumpval <- varray.[Seq.length varray - 1]
      else
        m.Jumpval <- varray.[m.Jumpadded - 1]
      f()

  /// X軸　キャラクタと障害物との当たり判定
  let collisionX (m:Mario) nextX = 
    let normal = false, m.X
    let px = nextX |> int
    let py = m.Y |> int
    let prec = posRect m px py

    let f (brec:Rectangle) =  
      let slowdown () =
        m.DashVX <- m.DashVX / 1.3
        m.LeverVX <- m.LeverVX / 1.3

      if prec.Intersects(brec) then
        if m |> getAcceleration > 0. then
          if brec.Left < prec.Right then
            slowdown ()
            true, (brec.Left - characterWidth) |> float
          elif brec.Right < prec.Left then
            slowdown ()
            true, brec.Right |> float
          else normal
        elif m |> getAcceleration < 0. then
          if brec.Left < prec.Right then
            slowdown ()
            true, brec.Right|> float
          elif brec.Right < prec.Left then
            slowdown ()
            true, (brec.Right + characterWidth)|> float
          else normal
        else normal
      else normal

    if m.Blocks = null || m.Blocks |> Seq.length = 0 then
      false, nextX
    else
      m.Blocks |> Seq.map f
      |> Seq.tryFind(fun (x,y) -> x) 
      |> function
      | None -> normal
      | Some x -> x

  /// キャラクタの描画
  let drawMario (m:Mario) (spriteBatch : SpriteBatch) (gameTime : GameTime) = 
    /// 状態に応じたSpriteEffectを返します
    let getSpriteEffect = fun () -> m.Direction |> function
      | Left  -> SpriteEffects.FlipHorizontally // 反転
      | Right -> SpriteEffects.None             // そのまま描画

    /// 現在のキャラクタテクスチャの短形を取得する
    let textureRectangle () =
      let height = m |> height
      if m.Condition = Squat then 
        Nullable (Rectangle(192, 16, characterWidth, height)) // しゃがみ
      elif m.Air && m.HeadBlock then
        Nullable (Rectangle(160, 0, width, height)) // 頭ぶつけて空中
      elif m.Air && m.Jumping |> not then
        Nullable (Rectangle(64, 0, width, height)) 
      elif m.Jumping then
        Nullable (Rectangle(160, 0, width, height))
      elif m |> getAcceleration = 0. then
        Nullable (Rectangle(96, 0, characterWidth, height))
      elif m.State = Break then
        Nullable (Rectangle(128, 0, characterWidth, height)) // ブレーキしてたら
      // 加速してたら
      elif m.State = Run then
        m.Timer <- m.Timer +  getAcceleration m * 4.
        let nextFrame = ref 0.
        m.Direction |> function
        | Left  -> nextFrame := baseFreamLeft -  getAcceleration m
        | Right -> nextFrame := baseFreamRight - getAcceleration m

        if m.Direction = Right && m.Timer > !nextFrame || m.Direction = Left && m.Timer < !nextFrame then
          m.Timer <- 0.
          let rect = Rectangle(moveFrame * characterWidth, 0, characterWidth, height)
          moveFrame <- moveFrame + 1
          if moveFrame > 2 then
            moveFrame <- 0
          Nullable rect
        else
          Nullable (Rectangle(moveFrame * characterWidth, 0, characterWidth, height))
      else
        Nullable (Rectangle(96, 0, characterWidth, height))

    /// 右向きのマリオのテクスチャ遅延ロード
    let marioTexture = lazy m.Game.Content.Load<Texture2D>(@"Content\image\right") 
    let px, py = m.X |> int, m.Y |> int
    spriteBatch.Draw(marioTexture.Force(), posRect m px py, textureRectangle (), Color.White, 0.f, Vector2.Zero, getSpriteEffect(), 0.f)

  /// 加速度から割り出される次のフレームのX座標
  let nextX (m:Mario) = Math.Ceiling(m.X + getAcceleration m)

  /// Verlet法から割り出される次のフレームのY座標
  let nextY (m:Mario) = m |> calcVerlet 

  /// X軸移動
  let moveX (m:Mario) =
    let nextX = nextX m
    let result,x = collisionX m nextX
    if (m.Air |> not && m.Condition = Squat) then
      if result |> not then
        m.X <- nextX |> float
      else
        m.X <- x 
    elif result |> not then
        m.X <- nextX |> float

  /// Y軸移動
  let moveY (m:Mario) = m.Y <- nextY m |> float

  /// 立つ
  let standUp (m:Mario) = 
    let py = m.Y - 17.
    if m |> getAcceleration <> 0. then
      let result,_ = collisionY m py false
      if not result then
        m.Condition <- Stand
    else
      let result,_ = collisionY m py false
      if not result then
        m.Condition <- Stand
      moveX m

  // 緩やかに減速
  let slowdown (m:Mario) = 
    if m.LeverVX > 0. then
      if m.LeverVX - leverAcceleration < 0. then
        m.LeverVX <-  0.
      else
        m.LeverVX <- m.LeverVX - leverAcceleration
    elif m.LeverVX < 0. then
      if m.LeverVX + leverAcceleration > 0. then
        m.LeverVX <-  0.
      else 
        m.LeverVX <- m.LeverVX + leverAcceleration
    if m.DashVX > 0. then
      if m.DashVX - leverAcceleration < 0. then
        m.DashVX <- 0.
      else
        m.DashVX <- m.DashVX - leverAcceleration
    elif m.DashVX < 0. then
      if m.DashVX + leverAcceleration > 0. then
        m.DashVX <- 0.
      else
        m.DashVX <- m.DashVX + leverAcceleration

  /// ブレーキ
  let break' (m:Mario) =  
    m.State <- Break
    m |> slowdown 

  /// 最大加速度を制御します
  let getMaxAcceleration (m:Mario) = 
    if m.LeverVX > 0. && m.LeverVX > leverMaxSpeed then
        m.LeverVX <- leverMaxSpeed
    elif (m.LeverVX < leverMaxSpeed * -1.) then
        m.LeverVX <- leverMaxSpeed * -1.
    if m.DashVX > 0. && m.DashVX > dashMaxSpeed then
        m.DashVX <- dashMaxSpeed
    elif (m.DashVX < dashMaxSpeed * -1.) then
        m.DashVX <- dashMaxSpeed * -1.

  /// デフォルトは右に加速
  let accel (m:Mario) f d c = 
    if m.Direction = Left then
      m.State <- Break
    if not m.Jumping then
      // 空中ではない場合キャラの向きを変える
      m.Direction <- c
    if m.LeverVX < 0. |> d then
      m.DashVX <- m.DashVX + f (dashAcceleration * 1.5)
      if m.DashVX >= 0. |> d then
        if m.DashVX - f (leverAcceleration * 0.8) < 0. then
          m.DashVX<- 0. 
        else
          m.DashVX <- m.DashVX - f (leverAcceleration * 0.8)
      m.LeverVX <- m.LeverVX + f (dashAcceleration * 2.5)
      if m.LeverVX >= 0. |> d then
        m.DashVX <- 0.
    else
      if m |> getAcceleration > 0. |> d then
        m.State <- Run
      if m.Dash then
        m.DashVX <- m.DashVX + f dashAcceleration
      else
        if m.DashVX > 0. |> d then
          if m.DashVX - f (leverAcceleration * 0.8) < 0. then 
            //m.DashVX <- 0. 
            m.DashVX <- m.DashVX - f (leverAcceleration * 0.8)
      m.LeverVX <- m.LeverVX + f leverAcceleration
    m |> getMaxAcceleration

Main.fs

namespace MgaGotoku
open MonoMac.AppKit
open MonoMac.Foundation
open System
open System.Linq 
open System.Collections.Generic
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 Microsoft.Xna.Framework.Media
open MarioLibrary

type GameState = Playing | Die | Gameover | End

/// Ｍが如く
type MgaGotokuGame () as this = 
  inherit Game()

  /// ゲームタイトル、グラフィックデバイスマネージャ、スプライトバッチ
  let gametitle, gmanager, sprite = "Ｍが如くF#ive 夢、叶えしMono", new GraphicsDeviceManager(this), lazy new SpriteBatch(this.GraphicsDevice)
  /// プレイヤー
  let mutable player : Mario = Unchecked.defaultof<_>
  /// ゲームの状態
  let mutable gameState = Playing

  /// コイン、フロアタイル、ソリッドタイル、土管のテクスチャ遅延ロード用
  let coinTexture,floorTileTexture,solidTileTexture,greenPipeTexture, gameoverTexture = 
    ["coin";"brownFloorTile";"brownSolidTile";"greenPipe";"gameover"] 
    |> List.map (fun name -> lazy this.Content.Load<Texture2D>(@"Content\image\" + name)) |> function 
    | a::b::c::d::e::[] -> a,b,c,d,e | _ -> invalidArg "tlist" "長さが違う"

  /// coin取得音
  let getCoin = lazy (this.Content.Load<SoundEffect>(@"Content\sound\getcoin"))
  /// die
  let die = lazy (this.Content.Load<SoundEffect>(@"Content\sound\smb_mariodie").CreateInstance())
  let gameover = lazy (this.Content.Load<SoundEffect>(@"Content\sound\smb_gameover").CreateInstance())

  /// ゲームのBGM遅延ロード用
  let bgm = lazy (this.Content.Load<SoundEffect>(@"Content\sound\overworld").CreateInstance()) 

  /// サンドを鳴らす
  let soundPlay (se:Lazy<SoundEffectInstance>) = se.Force().Play()

  // 配置するフロアタイル
  let floors = [-5..15]@[17..30] |> List.map (fun x -> new Rectangle(33 * x, 452, 32, 32))
               
  // フロアタイルの描画  
  let drawFloors () =
    // すべてのフロアタイルを描画
    floors |> List.iter (fun rect -> sprite.Force().Draw(floorTileTexture.Force(), rect,  Color.White))

  // 配置するブロック
  let blocks = [2..4] |> List.map (fun x -> new Rectangle(100 + 32 * x, 416 - (33 * (x - 1)), 32, 32))
  // ブロックの描画  
  let drawBlocks () =
    // すべてのブロックを描画
    blocks |> List.iter (fun rect -> sprite.Force().Draw(solidTileTexture.Force(), rect,  Color.White))

  // アニメーション用テクスチャRectangleを取得するクロージャー
  let animationTextureRectangle width hight max  = 
    let flame = 10
    let animeWait, counter = ref 0, ref 0
    (fun () -> 
      animeWait := !animeWait + 1
      let rect = new Rectangle(!counter * width, 0, width, hight)
      if !animeWait > flame then 
        animeWait := 0;
        incr counter
        if !counter > max then counter := 0
        Nullable rect
      else Nullable rect)

  // 配置するコイン
  let coins = new List<Rectangle>()  
  // コインの点滅を表現
  let coinTextureRect = animationTextureRectangle 20 28 3 
  // コインの描画
  let drawCoins () =
    // クロージャからコインのカレントテクスチャRectangleを取得
    let coinRect = coinTextureRect ()
    // すべての配置するコインを描画
    coins.ToList() |> Seq.iter (fun rect -> sprite.Force().Draw(coinTexture.Force(), new Vector2(rect.X |> float32, rect.Y |> float32), coinRect,  Color.White))

  // 配置する土管
  let greenPipes = [0..0] |> List.map (fun x -> new Rectangle(32 * 15, 452-77 , 48, 77))
  // 土管の描画
  let drawGreenPipes () =
    // すべての配置する土管を描画
    greenPipes |> List.iter (fun rect -> sprite.Force().Draw(greenPipeTexture.Force(), rect,  Color.White))

  /// コインとの当たり判定
  let checkTouchCoin =
    let wait =ref 0.
    (fun () -> 
      async { let terget = coins.ToList()
              wait := !wait + 1.
              if !wait > 2. then
                let prect = new Rectangle(player.X |> int, player.Y |> int, 32, 52)
                terget |> Seq.filter (fun coin -> prect.Intersects(coin)) 
                        |> Seq.iter (fun coin -> ignore <| getCoin.Force().Play(); ignore <| coins.Remove(coin))
                wait := 0. } |> Async.Start)

  /// X座標における画面からはみ出した場合、反対側から出てくるように
  let checkWindowOut () =
    if player.X > 800. && player |> getAcceleration > 0. then
      player.X <- -32.// 画面右隅へ
    if player.X < -32. && player |> getAcceleration < 0. then
      player.X <- 800.// 画面左隅へ

  /// しんでしまったか判定
  let checkDie () =
    if gameState = Playing && player.Y > 510. then
      ignore <| bgm.Force().Stop()
      ignore <| die.Force().Play()
      gameState <- Die

  /// プレイヤーの情報を更新
  let updatePlayer () = 
    let f () = 
      player |> moveX ; player |> moveY
      checkTouchCoin >> checkWindowOut >> checkDie <| ()
    // ゲームの終了条件をチェックします。
    if (GamePad.GetState(PlayerIndex.One).Buttons.Back = ButtonState.Pressed) then
        this.Exit()
    // ジャンプ処理
    if player.Jumping |> not then
      if (Keyboard.GetState(PlayerIndex.One).IsKeyDown(Keys.Z) && (player.HeadBlock |> not)) then
        if (player.Air |> not) then
          player |> jump
    elif player.Jumping then
      if (Keyboard.GetState(PlayerIndex.One).IsKeyDown(Keys.Z) |> not) then
        player.JumpUp <- false

    // 左右両方入力されていたら
    if (Keyboard.GetState(PlayerIndex.One).IsKeyDown(Keys.Right) &&
        Keyboard.GetState(PlayerIndex.One).IsKeyDown(Keys.Left)) then
      // ブレーキ
      player |> break'; f ()
    else
      // 左右未入力なら緩やかに減速
      if ((Keyboard.GetState(PlayerIndex.One).IsKeyDown(Keys.Right) |> not) && (Keyboard.GetState(PlayerIndex.One).IsKeyDown(Keys.Left) |> not)) then
        if (Keyboard.GetState(PlayerIndex.One).IsKeyDown(Keys.Down)) then
          player.Condition <- Squat
          // 緩やかに減速
          player |> slowdown; f ()
        else
          player |> standUp 
          player |> slowdown; f ()
      else
        player |> standUp
        if (Keyboard.GetState(PlayerIndex.One).IsKeyDown(Keys.Right)) then
          if (Keyboard.GetState(PlayerIndex.One).IsKeyDown(Keys.X)) then
            player.Dash <- true
          else
            player.Dash <- false
          accel player id id Right
        if (Keyboard.GetState(PlayerIndex.One).IsKeyDown(Keys.Left)) then
          if (Keyboard.GetState(PlayerIndex.One).IsKeyDown(Keys.X)) then
            player.Dash <- true
          else
            player.Dash <- false
          accel player (fun x -> -1. * x) not Left
        f ()

  /// デフォルトコンストラクタ
  do 
    gmanager.PreferredBackBufferWidth  <- 800 // Windowの横幅
    gmanager.PreferredBackBufferHeight <- 480 // Windowの縦幅
    this.TargetElapsedTime <- TimeSpan.FromSeconds(1./60.)

  /// ゲームが実行開始する前に必要な初期化処理をここに書きます。
  override this.Initialize() =
    // ウィンドウタイトルを設定
    base.Window.Title <-gametitle;

    // コインを配置
    let d, m, width, height = 30, 25, 20, 28
    let space = 
      let f source = [0..31] |> Seq.filter(fun x -> source |> Seq.exists (fun y -> x = y) |> not )
      seq { yield [] |> f 
            yield [10..14]@18::[20] |> f 
            yield [10;18;20;] |> f        
            yield 10::[17..21] |> f
            yield [10..13]@18::[20] |> f 
            yield 10::[17..21] |> f            
            yield [10;18;20;] |> f
            yield [10;18;20] |> f
            yield [] |> f 
            yield [] |> f } 
      |> Seq.mapi (fun i x -> x,i)
    space |> Seq.iter (fun (h,i) -> h |> Seq.iter (fun x -> coins.Add(new Rectangle(m * x, d * i, width, height))))

    // BGMを鳴らす
    ignore <| bgm.Force().Play() 
    base.Initialize()

  /// LoadContentはゲームごとに１回呼び出されます。
  /// 基本的には、ここですべてのコンテンツを読み込みます。
  override this.LoadContent() =
    player <- createMario 0. 400. this
    player.Blocks <- floors.Concat(blocks).Concat(greenPipes)
    base.LoadContent()

  /// UnloadContentはゲームごとに１回呼び出されます。
  /// ここですべてのコンテンツをアンロードします。
  override this.UnloadContent () = 
    base.UnloadContent()

  /// ゲームの状態の更新処理をここに書きます。
  /// プレイヤーの入力判定、キャラクタの衝突判定、オーディオの再生などなど
  override this.Update(gameTime) = 
    gameState |> function
    | Playing  -> 
      updatePlayer ()
    | Die -> 
      if die.Force().State = SoundState.Stopped then
        gameState <- Gameover
    | Gameover ->
        gameover.Force().Play()
        gameState <- End
    | End -> ()
    base.Update gameTime

  /// ゲームの描画処理をここに書きます
  /// gameTimeは、ゲームの瞬間的なタイミング情報です。
  override this.Draw(gameTime) = base.Draw gameTime |> fun _ ->
    gameState |> function
   | Playing | Die ->
      gmanager.GraphicsDevice.Clear(Color.CornflowerBlue)
      // スプライトバッチ処理開始
      sprite.Force().Begin ()
      // 各描画処理を実行
      [drawFloors; drawCoins;drawBlocks;drawGreenPipes;] |> List.iter (fun f -> f())
      // プレイヤーを描画
      drawMario player (sprite.Force()) gameTime
      // スプライトバッチ処理終了
      sprite.Force().End ()
    | Gameover | End ->
      gmanager.GraphicsDevice.Clear(Color.Black)
      sprite.Force().Begin ()
      sprite.Force().Draw(gameoverTexture.Force(), Vector2(200.f,150.f), Color.White)
      sprite.Force().End ()

  /// 終了時の処理をここに書きます。
  override this.EndRun () = base.EndRun()

type AppDelegate() = 
    inherit NSApplicationDelegate()
    
    override x.FinishedLaunching(notification) =
        let game = new MgaGotokuGame()
        game.Run()
    
    override x.ApplicationShouldTerminateAfterLastWindowClosed(sender) =
        true
 
module main =         
    [<EntryPoint>]
    let main args =
        NSApplication.Init ()
        using (new NSAutoreleasePool()) (fun n -> 
            NSApplication.SharedApplication.Delegate <- new AppDelegate()
            NSApplication.Main(args) )
        0


マリオの歩行とダッシュ
マリオは左右の方向キーが押下されている間、歩行状態となり特定のスピードまで加速します。左右の方向キーに加えてダッシュ用のボタンを押下していると、さらに最大スピードに達するまで加速します。というのが、横移動の基本となります。


減速
これは歩行とダッシュに密接に関係があるところ。加速があれば減速もある、そりゃそうだ。運動には慣性が働くもの。それを無視してしまうと非常に違和感のあるものになります。方向キーが離さてすぐにキャラクタがその場に急停止してしまうと非常に不自然です。なのでボタンが離されると緩やかに減速してから停止するように速度を調整してやる必要があります。物理エンジンでも使っていれば、この辺のことは勝手にやってくれるんでしょうが。


他にも移動している方向と逆に方向キーを入力したとき、急ブレーキをする表現があったり、移動中にしゃがむことで緩やかに減速するなど、細かな仕様を満たす必要がある。


マリオのジャンプの実装
マリオのジャンプは、これまでも様々なアクションゲームで模倣されてきたと思う。ボタンの押下時間に応じてジャンプ力が変化するところなんかは、アクション性に大きな影響を与えている。あの心地よい放物線を描くジャンプは、どんな風につくられているのか？ 以前、読んだマリオのジャンプ実装法とVerlet積分 - Gemmaの日記を思い出しまして、再度拝見。なるほどーシンプルな原理でつくられているんですね。とりあえずそのままやってみると、当然ジャンプはする。だが、記事のまんま実装してもマリオ的な放物線にはならない。まぁそりゃそうですよね。続編として、マリオのジャンプ実装法とVerlet積分(実践編) - Gemmaの日記もありますが、ソースコードへのはリンクは切れていた。Verlet法というのを使うといい感じにできるということがわかったので、ググってみる。すると、どうやら分子動力学に関する話題のようである。なんとなく理屈はわかったけどどう実装すれば？なるほどわからん。



すると、そのままズバリのわかりやすい良記事を発見。ありがたい。→ ジャンプしたときの座標をVerlet法で求める - 無職のプログラミング



上記記事では、既定値とする地面(Y座標)に操作対象のオブジェクトが接地しているときは、キャラクタに重力が働かないように実装されてる。それだと、ジャンプして上にあるブロックに乗っかることもできないし、乗っかったブロックから落下することもできない。なので、記事を参考にしつつジャンプをしていないときも常にキャラクタに重力がかかるように実装する。するとマリオ的なジャンプのソレがうまいこといく。誤解を恐れずにいうと、使う側からすると、Verlet法というのは「現在の位置と前回の位置と経過する時間から次の位置を割り出せば楽じゃん」というもの。キャラクタの位置状況を把握しやすいし便利。よくよく考えてみると、X軸方向の移動に関しても結局は時間経過による移動なので、同様の方法で実装することもできる。ただ、マリオを表現する場合、移動している方向と逆に方向キーを入力したとき、急ブレーキをする表現が必要なので、キー入力時間による加速度を制御したほうが、実装は楽かもしれません。結果オーライだった。


コインの取得（というか、物体との当たり判定）
MonoGame(XNA)には、矩形（四角形の位置とサイズ）を表すのに便利な Rectangle構造体 があります。Rectangle構造体 には、当たり判定（ある矩形が別の矩形に重なるかを判定）を手軽にできるIntersectメソッドが提供されています。なので、それを使えばあたり判定できる。ただし、これだけではどの方向からどの面に対してぶつかったのかの判定材料にはならないので、実際に必要な当たり判定を得るには、もう少し考慮が必要となる。判定をミスるとキャラが地面やブロックにめり込んで残念なことに。




よくわかりませんが、だいぶＭが如く感（マリオっぽさ）を出せたんじゃないだろうか。これくらい実装できてくると、だんだんと面白くなってきて次第に欲がでてくる。ステージ１−１を丸ごと実装しようかななんて脳裏に浮かんだけど、冷静に考えると非常に面倒くさそうなので１発ネタはこれにて終了。ただ、今回書いたコードはあまりにもやっつけ仕事すぎるので、余裕ができたらキレイに書き直してみたいかも。



まとめ：つまり結局、どういうことだってばよ！？

ﾄﾞﾗｲﾊﾞｰ　ｵﾝ


ﾓﾉﾄﾞｩﾋﾞﾀｯﾁﾍｰﾝｼｰﾝ!　
ﾓﾉﾄﾞｩﾋﾞﾀｯﾁﾍｰﾝｼｰﾝ!　
ﾓﾉﾄﾞｩﾋﾞﾀｯﾁﾍｰﾝｼｰﾝ!　


ﾓﾉｹﾞｰﾑ ﾌﾟﾘｰｽﾞ ｴー、ｴー! xna!


ﾓﾉﾃﾞﾍﾞﾛｯﾌﾟ ﾍｰﾝｼｰﾝ!　
ﾓﾉﾃﾞﾍﾞﾛｯﾌﾟ ﾍｰﾝｼｰﾝ!　
ﾓﾉﾃﾞﾍﾞﾛｯﾌﾟ ﾍｰﾝｼｰﾝ!　


ｱﾊﾞﾝﾁｭ・ﾏｯｸ・ﾀｯﾁｺﾞｰ!


ｷｬﾓﾅ ｴﾌｼｬｰﾌﾟ ｼｪｲｸﾊｰﾝｽﾞ ﾁｮｰｲｰﾈ!!
任意のOSで実行!! ｻｲｺｰ!!


「さぁ、Show Timeだ」




次は、@otfさんですね。楽しみです。

圏論でアハ体験

プログラミング Haskell F# 勉強会 モナド 代数的構造 圏論 アハ体験 Code

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


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



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



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



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



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




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




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




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




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




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




じゃいつやるか？今でしょ！




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




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




どういうことだってばよ！？




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




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




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




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




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




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




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




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




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




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




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




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




基礎の基礎が大事です。




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

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




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




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




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




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




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




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




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




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




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




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




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




どういうことなの？




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




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




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




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




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




圏空気すぎワロタ






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




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






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




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

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

プログラミング 関数型プログラミング F# F#上達法 息抜き

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

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



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

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



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

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

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

とりあえず書いた。

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

  printfn "%d" tensaku


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



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

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

  printfn "%d" tensaku

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


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

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

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

  printfn "%d" tensaku

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



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

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


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

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

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

  printfn "%d" tensaku


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

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

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

  printfn "%d" tensaku


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



F#の上達法



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


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



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

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

プログラミング F# F#2.0 FSharpx 限定継続 delimited continuation Scala モナド


発売されてすぐに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#3.0で加速する言語指向プログラミング(LOP)。コンピューテーション式はもはやモナドだけのための構文ではない！！！

プログラミング F# F#3.0 言語指向プログラミング DSL コンピューテーション式 MSIL Rx



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


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

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



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

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



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



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



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



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



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



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


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




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




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

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

let myseq = SeqBuilder() 

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


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




ProjectionParameterAttributeの利用

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

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

let myseq = SeqBuilder() 

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

MaintainsVariableSpaceプロパティの利用

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

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

let myseq = SeqBuilder() 

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


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



サンプル：FizzBuzzBuilder

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


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

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

let fizzbuzz = FizzBuzzBuilder()


サンプル：もっとFizzBuzzBuilder

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

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


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

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

let fizzbuzz = FizzBuzzBuilder()


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




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



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



サンプル：ILBuilder

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




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


open System.Reflection.Emit 

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

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

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

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

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

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

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

let il = ILBuilder()


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




RxQueryBuiler

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


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



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

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

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

let rxquery = new RxQueryBuiler()


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



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

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

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

F#で逆FizzBuzz問題

プログラミング F# 息抜き ネタ

元ネタ
逆FizzBuzz問題 (Inverse FizzBuzz) - 猫とC#について書くmatarilloの雑記
http://d.hatena.ne.jp/matarillo/20120515/p1

　

面白いですねえ。




無理矢理詰め込んでツイートしたけど、F#で140文字ゴルフプログラミングとか割と無茶ですから！（白目

F#で逆FizzBuzz問題

二番煎じというのは、面白さ半減どころかほぼ面白みなし！的な雰囲気がありますが、
ゴルフなスニペットだけ置いておくのもアレなので実装例全体をのっけとく。

open System

let fzbz lst = 
  let isFizzBuzz x = if x%3 = 0 || x%5 =0 then true else false
  let toFizzBuzz x = 
    (x%3,x%5) |> function
    |0,0 -> "fizzbuzz"
    |0,_ -> "fizz" 
    |_ -> "buzz"
  [for x in lst do if isFizzBuzz(x) then yield toFizzBuzz(x)]

let range n = [1..n] |> List.map (fun x -> [x..n] |> List.map (fun y -> x,y)) |> List.collect id
                     |> List.sortBy (fun (a,b) -> b - a) 
let inverses x = range 100 |> List.find (fun (a,b) -> fzbz [a..b] = x)

printfn "%A" <| inverses ["fizz"]               // (3,3)
printfn "%A" <| inverses ["buzz"]               // (5,5)
printfn "%A" <| inverses ["fizz";"fizz";"buzz"] // (6,10)
printfn "%A" <| inverses ["fizz";"buzz"]        // (9,10)
printfn "%A" <| inverses ["buzz";"fizz"]        // (5,6)
printfn "%A" <| inverses ["fizz";"buzz";"fizz"] // (3,6)
printfn "%A" <| inverses ["fizz";"fizz"]        // (6,9)
printfn "%A" <| inverses ["fizz";"fizzbuzz"]    // (12,15)

Console.ReadLine () |> ignore

元ネタの元ネタのScalaでの解説は、確かにストーリー的には面白いものになっているけど、プログラムとしては結構無駄な計算が多くて、それってどうなの？ってー感じがしないこともなくもない。上記のように、探索対象を範囲が狭くて小さい順に先にソートしてから探索して、最初に一致したものを返すという考え方の方が、計算量も少なくなりますし自然ですね。


　
いげ太さんに禿同と言わざるを得ない。まぁ、抽象化の超パワーを無視することは（おれは）できないけどね！
ちなみに、F#は書き味のほうも最高峰レベルなので使ったら気に入ること間違いなしだよっウフフオッケー☆




追記：5/17
対象が見つからない場合も考慮したやつ

open System

let fzbz lst = 
  let isFizzBuzz x = if x%3 = 0 || x%5 =0 then true else false
  let toFizzBuzz x = 
    (x%3,x%5) |> function
    |0,0 -> "fizzbuzz"
    |0,_ -> "fizz" 
    |_ -> "buzz"
  [for x in lst do if isFizzBuzz(x) then yield toFizzBuzz(x)]

let range n = [1..n] |> List.map (fun x -> [x..n] |> List.map (fun y -> x,y)) |> List.collect id
                     |> List.sortBy (fun (a,b) -> b - a) 
let inverses = function
| [] -> None
| x  -> range 100 |> List.tryFind (fun (a,b) -> fzbz [a..b] = x)

let print = function
| Some x -> printfn "%A" <| x
| None   -> printfn "None"

print <| inverses ["fizz"]                // (3,3)
print <| inverses ["buzz"]                // (5,5)
print <| inverses ["fizz";"fizz";"buzz"]  // (6,10)
print <| inverses ["fizz";"buzz"]         // (9,10)
print <| inverses ["buzz";"fizz"]         // (5,6)
print <| inverses ["fizz";"buzz";"fizz"]  // (3,6)
print <| inverses ["fizz";"fizz"]         // (6,9)
print <| inverses ["fizz";"fizzbuzz"]     // (12,15)
print <| inverses []                      // None
print <| inverses ["orz"]                 // None
print <| inverses ["fizzbuzz";"fizzbuzz"] // None

Console.ReadLine () |> ignore

F#で簡素なモゲマスコンプガチャシミュレータ

プログラミング F# FSharpx コンピューテーション式 モナド 息抜き ネタ

椎名林檎「自由へ道連れ」をヘビロテしすぎて脳内無限ループしている今日この頃ですが、皆様いかがお過ごしでしょうか。
時事ネタとしては旬を逃した感じですが、簡素なコンプガチャシミュレータをF#で書いてみました。



とは言っても、この記事で伝えたいことはコンプガチャの確率がどうのですとか、実社会におけるコンプガチャの問題点がどうのとかいうような話題を扱うものではなく、安直にモナド則を満たさないコンピューテーション式を作ってしまうよりかは、Identityモナド(恒等モナド)を使ってプログラミングをした方が、見通しが良くモジュール性の高いコードを書くことができるかもしれないよ、という話題を提供します。割とどうでもいい話題ですね。未だガラケーユーザーであり、スマホやソーシャルゲーとはほとんど縁のない私ですが（もちろんモゲマスもやったことない）、気が向いたのでちょっと書いてみました。なお、モゲマスおよびFSharpxのステマではありません。


シミュレートするコンプガチャの仕様

まずはシミュレートするコンプガチャの仕様について簡単に確認しておきましょう。今回実装してみるのは、モゲマスことモバゲー『アイドルマスター シンデレラガールズ』のコンプガチャ「パジャマパーティー」に近いコンプガチャのシミュレートを目的としてみます。




Google先生に聞いてきた モゲマス 「パジャマパーティー」コンプガチャの概要

時折行われる課金ガチャのイベント企画。1ガチャあたり300円を支払って利用するガチャです。1回に1枚のアイドルカードが得られます。実際の支払いは「モバコイン」ですが、モバコインは100G＝100円で購入して利用するため、便宜上こちらではそのまま円とします。イベント期間中以下の「レア」パジャマアイドルが確率テーブルに5枚追加され、その5枚を全て集めると、特典として限定「Sレア」カード「［眠れる姫君］星井美希」を獲得できるというもの。


コンプ対象パジャマアイドル
・[パジャマパーティー]緒方智絵里 コスト12 攻2880 守1600 キュート攻中アップ
・[パジャマパーティー]間中美里 コスト08 攻1240 守1440
・[パジャマパーティー]黒川千秋 コスト10 攻1860 守1560 クール攻中アップ
・[パジャマパーティー]川島瑞樹 コスト09 攻1400 守1680
・[パジャマパーティー]若林智香 コスト12 攻1600 守2680 パッション守中アップ



なお、バンナムによる公式の発表はないが、いずれかのパジャマアイドルが出現する確率は12%程度とのこと。
　　
※ガチャのセット販売も行われているが、ここでは1回ずつガチャを行うこととする。
※なお、ネットで適当に拾ってきた情報のため正確ではない可能性あり。

内部の実装の詳細はわかりませんが、「今すぐモゲマスＰすべてにＳレアを授けてみせろッ！ ver. 0.141.33」というシミュレータが既にあるようです。
http://mugenmasakazu.plala.jp/cgi-bin/nijiuraIDOLMASTER/mogemaskillyourself.cgi



なお、コンプガチャがどうして危険と言われているのかの理由については、「コンプガチャの確率マジックを中学生にも分かるように説明するよ -　てっく煮ブログ」の解説がわかりやすい。わたしが中学生にも分かるように説明するなら、例えばモンハンの素材であるところの「逆鱗(出現率2%)」が5種類あったとして、それらすべてを揃えないと作れない武器があったとき、それにかかる時間を想像してみると、コンプガチャへ挑む無謀さが割と想像しやすい、とか。欲しいと思う素材ほど出ないようになっているといわれる架空のシステム。いわゆる「センサー」の存在への疑い、とか。



簡素なコンプガチャシミュレータを愚直に書いてみる

まずは愚直に。細かいことは考えずにとりあえず実装してみたバージョン。

open System

let tee x f = f x; x
let (|>!) x f= tee x f

let rand = new Random(DateTime.Now.Millisecond);

type Rarity = 
  |R of string 
  |Other

// ガチャアイテム
let a,b,c,d,e,other = R("緒方智絵里"), R("間中美里"), R("黒川千秋"), R("川島瑞樹"), R("若林智香"), Other

// コンプ
let comp = [a;b;c;d;e]

// コンプ対象が出る確率
let probability = 0.12

let shuffle source =
  let array = List.toArray source
  let rec loop i =
    i |> function
    | 1 -> ()
    | _ ->
      let i =  i - 1
      let j = rand.Next(i)
      let temp = array.[i]
      array.[i] <- array.[j]
      array.[j] <- temp;
      loop i
  loop source.Length
  [for x in array do yield x]

let completeGacha lst count total =
  let items = 
    let dummy p = 
      let e = ((float comp.Length) / p) |> int
      [for i in 1..(e-comp.Length)  do yield Other]
    let target = comp@dummy probability 
    target |> shuffle

  let gacha () = rand.Next(1, items.Length) |> fun i -> items.[i]

  let rec gacha' count total =
    let newitem = gacha ()
    let current = count + 1
    if List.exists (fun x -> x = newitem) comp |> not then
      (* でねぇ！！！*)
      gacha' current total
    elif List.forall (fun x -> x = newitem |> not) lst |> not then
      (* ダブりかよ...orz *)
      gacha' current total
    else
      (* よっしゃー！なんという引きの良さ！！！ *)
      lst@[newitem], current, (total + current), List.length (lst@[newitem]) = comp.Length
  gacha' count total

let printGacha x = 
  x |>! (fun (possession, n, total, complete) -> 
          let g = sprintf "%d回：%d円 " n (300 * n)
          let sum = sprintf "合計%d円" (300 * total)
          let result = sprintf "%s" (if complete then "コンプ" else "未コンプ")
          printfn "%s %s %A %s" g sum possession result)
  
let cut (a,b,c,d) = a,b,c

completeGacha [] 0 0 |> printGacha |> cut
|||> completeGacha |> printGacha |> cut
|||> completeGacha |> printGacha |> cut
|||> completeGacha |> printGacha |> cut
|||> completeGacha |> printGacha |> cut
|> fun _ -> printfn "［眠れる姫君］星井美希を手に入れた！" 

Console.ReadLine () |> ignore


ジェネリックもへったくれもない。いくら適当とはいえ愚直すぎて泣ける。



結果は当然実行ごとに毎回変わりますが、一応実行結果の例。

1回：300円  合計300円 [R "黒川千秋"] 未コンプ
8回：2400円  合計2700円 [R "黒川千秋"; R "緒方智絵里"] 未コンプ
38回：11400円  合計14100円 [R "黒川千秋"; R "緒方智絵里"; R "川島瑞樹"] 未コンプ
78回：23400円  合計37500円 [R "黒川千秋"; R "緒方智絵里"; R "川島瑞樹"; R "間中美里"] 未コンプ
108回：32400円  合計69900円 [R "黒川千秋"; R "緒方智絵里"; R "川島瑞樹"; R "間中美里"; R "若林智香"] コンプ
［眠れる姫君］星井美希を手に入れた！

1回目でレアカード"黒川千秋"を引き当てるという強運を発揮するも、2枚目のレア"緒方智絵里"を引き当てるには8回かかる。
そして、あらあらまあまあ最終的には合計69900円のぶっこみ。バンナムにかなり貢ぎましたな。



簡素なコンプガチャシミュレータをコンピューテーション式で

愚直にもほどがあるので、もうちょっとなんとかしてみましょう。

completeGacha [] 0 0 |> printGacha |> cut
|||> completeGacha |> printGacha |> cut
|||> completeGacha |> printGacha |> cut
|||> completeGacha |> printGacha |> cut
|||> completeGacha |> printGacha |> cut
|> fun _ -> printfn "［眠れる姫君］星井美希を手に入れた！"

上記部分に着目すると、なんだか順々に関数を適用していく流れが見えます。なんだかコンピューテーション式にできそうです。
ということで、とりあえずコンピューテーション式にしてみる。

namespace Library1

[<AutoOpen>]
module CompleteGacha =
  open System

  let tee x f = f x; x
  let inline (|>!) x f= tee x f

  let rand = new Random(DateTime.Now.Millisecond);
  let shuffle source =
    let array = List.toArray source
    let rec loop i =
      i |> function
      | 1 -> ()
      | _ ->
        let i =  i - 1
        let j = rand.Next(i)
        let temp = array.[i]
        array.[i] <- array.[j]
        array.[j] <- temp;
        loop i
    loop (List.length source)
    [for x in array do yield x]

  let completeGacha comp d probability (lst:'a list) count total =
    let items = 
      let dummy p = 
        let e = ((float <| List.length comp) / p) |> int
        [for i in 1..(e - (List.length comp)) do yield d]
      let target = comp@(dummy probability)
      target |> shuffle

    let gacha () = 
      let i = rand.Next(1, (List.length items)) 
      items.[i]

    let rec gacha' count total =
      let newitem = gacha ()
      let current = count + 1
      if List.exists (fun x -> x = newitem) comp |> not then
        (* でねぇ！！！ *)
        gacha' current total
      elif List.forall (fun x -> x = newitem |> not) lst |> not then
        (* ダブりかよ...orz *)
        gacha' current total
      else
        (* よっしゃー！なんという引きの良さ！！！ *)
        lst@[newitem], current, (total + current), List.length (lst@[newitem]) = List.length comp
    gacha' count total

  type CompGacha<'a> = CompGacha of 'a 

  type CompGachaBuilder () =
    member this.Bind(m, f) : CompGacha<_> = 
      let (CompGacha (comp, d, p, lst,count,total,complete)) = m
      let lst,count,total,complete = completeGacha comp d p lst count total 
      f (comp,d, p, lst,count,total,complete)
    member this.Return x = CompGacha(x)
    member this.ReturnFrom x = x

  let cg = new CompGachaBuilder()

  let printGacha price unit f x = 
    x |>! (fun (comp, d, p, possession, n, total, complete) -> 
            let g = sprintf "%d回：%d%s" n (price * n) unit
            let sum = sprintf "合計%d%s" (price * total) unit
            let result = sprintf "%s" (if complete then "コンプ" else "未コンプ")
            printfn "%s %s %A %s" g sum possession result
            if List.length comp = List.length possession then 
              f())

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

利用側

open System
open Library1

type Rarity = 
  |R of string 
  |Other

// ガチャアイテム
let a,b,c,d,e,other = R("緒方智絵里"), R("間中美里"), R("黒川千秋"), R("川島瑞樹"), R("若林智香"), Other

// コンプ
let comp = [a;b;c;d;e]

// コンプ対象アイテムが出る確率
let probability = 0.12 // 12%

// １ガチャあたり300円
let printg = printGacha 300 "円" (fun () -> printfn "［眠れる姫君］星井美希を手に入れた！") 

let mogemasu x = 
  cg { return x } 
  >>= fun x -> cg { return x |> printg } 
  >>= fun x -> cg { return x |> printg } 
  >>= fun x -> cg { return x |> printg } 
  >>= fun x -> cg { return x |> printg } 
  >>= fun x -> cg { return x |> printg } 

// 別の書き方
//let mogemasu x = 
//  cg { let! x = cg { return x } 
//       let! x = cg { return x |> printg } 
//       let! x = cg { return x |> printg } 
//       let! x = cg { return x |> printg } 
//       let! x = cg { return x |> printg } 
//       return x |> printg }

(comp, other, probability, [], 0, 0, false) |> mogemasu |> ignore
Console.ReadLine () |> ignore

とりあえずコンピューテーション式にしました以外の何物でもない。愚直版に比べるとそこそこ抽象化こそされているが、まだ不十分。コンプ対象カード中何枚揃えるまでガチャを行うかの部分がハードコーディングされている（この場合は5回のBindをすることで5枚揃えるまでガチャしている）。ちなみに、このコンピューテーション式は「Functor且つApplicative且つモナド」を満たさない。「コンピューテーション式がモナドである必要は必ずしもない」が、このような実装ではモジュール性の低下は否めない。



簡素なコンプガチャシミュレータをIdentityモナドで

HaskellでIdentityモナド(恒等モナド)と言えば、一般的にはモナド変換子からモナドを導出するために使われることで知られている。内部処理を伴わない単なる関数適用をモナドで表現する目的でIdentityモナドを使うことは、Haskellではあまりしないのかもしれない。しかし、まったく意味がないというわけではない。モナドを利用することで、モジュール性が高まりプログラムの見通しが良くなる。「Functor且つApplicative且つモナド」ではないコンピューテーション式をわざわざ作るよりかは、Identityモナドを使った実装の方が見通しの良いプログラムが書けるかもしれない。



ではやってみよう。
FSharpxには標準で実装されていないため、まずはIdentityモナドをつくる必要がある。

module Identity =
  type M<'T> = M of 'T 
  let mreturn x : M<'T> = M x

  type IdentityBuilder () =
    member this.Return (x) = mreturn x
    member this.Bind ((M x),f) : M<'U> = f x

  let identity = IdentityBuilder ()

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

利用側

open System
open Library1
open Library1.Identity

type Rarity = 
  |R of string 
  |Other

// ガチャアイテム
let a,b,c,d,e,other = R("緒方智絵里"), R("間中美里"), R("黒川千秋"), R("川島瑞樹"), R("若林智香"), Other

// コンプ
let comp = [a;b;c;d;e]

// コンプ対象アイテムが出る確率
let probability = 0.12 // 12%

// １ガチャあたり300円
let printg = printGacha 300 "円" (fun () -> printfn "［眠れる姫君］星井美希を手に入れた！") 

let compGacha x = 
  identity { let comp,d,probability,lst,count,total,r  = x
             let lst,count,total,r = completeGacha comp d probability lst count total 
             return (comp,d,probability,lst,count,total,r ) |> printg }

let mogemasu () = 
  (comp, other, probability, [], 0, 0, false) |> fun x -> 
  compGacha x >>= compGacha >>= compGacha >>= compGacha >>= compGacha 

// 別の書き方
//let mogemasu () = 
//  (comp, other, probability, [], 0, 0, false) |> fun x -> 
//  identity { let! x = compGacha x 
//             let! x = compGacha x 
//             let! x = compGacha x 
//             let! x = compGacha x
//             let! x = compGacha x 
//             return x }

mogemasu () |> ignore
System.Console.ReadLine () |> ignore

Console.ReadLine () |> ignore


Identityモナドを用いて実装することにより、冗長なコンピューテーション式をわざわざ作らなくても、見通しがよいコードを書くことができた。しかも、これはモナドであるためモジュール性が高い。その証拠にモナド則３の結合則から「何枚揃えるまでガチャを行うか」についての抽象を導き出すことができる。



例えばこうだ。

open System
open Library1
open Library1.Identity

type Rarity = 
  |R of string 
  |Other

// ガチャアイテム
let a,b,c,d,e,other = R("緒方智絵里"), R("間中美里"), R("黒川千秋"), R("川島瑞樹"), R("若林智香"), Other

// コンプ
let comp = [a;b;c;d;e]

// コンプ対象アイテムが出る確率
let probability = 0.12 // 12%

// １ガチャあたり300円
let printg = printGacha 300 "円" (fun () -> printfn "［眠れる姫君］星井美希を手に入れた！") 

let compGacha x = 
  identity { let comp,d,probability,lst,count,total,r  = x
             let lst,count,total,r = completeGacha comp d probability lst count total 
             return (comp,d,probability,lst,count,total,r ) |> printg }

let mogemasu n = 
  (comp, other, probability, [], 0, 0, false) |> fun x -> 
  let cg = [for i in 1..n-1 do yield compGacha]
  List.fold (fun m f -> m >>= f) (compGacha x) cg

mogemasu 5 |> ignore
System.Console.ReadLine () |> ignore

Console.ReadLine () |> ignore


List.foldで必要回数分のモナドを結合することで、mogemasu関数を汎化することができた。
なお、List.foldでモナドを結合している部分は、下記のようにList.foldBackに書き直しても同様に動作する。このことからもモナド則３を満たしていることが確認できる。

let mogemasu n = 
  (comp, other, probability, [], 0, 0, false) |> fun x -> 
  let cg = [for i in 1..n-1 do yield compGacha]
  List.foldBack (fun m f -> f >>= m) cg (compGacha x)


まとめ
そのまま適用しただけでは何もしてくれないので、一見使いどころがなさそうなIdentityモナド。
しかし、使えないようでいて実は割と使えるかもしれない、という話題でした。





読者の中には記事の誘導によってうまいこと騙されている人もいるかもしれないけど、
いや...、つーかさ。それ再帰で書けばいんじゃね？（核心


　　　　　　　　i l l　　　　　　　　　　　　ヽ　　　　ヽ＼＼
　　　　　　　　ヾy　‐-~~~　ヽ、　　　　＼　　　 ヽ　ヽ
　　　　　　　　 ィ　　　ヽ~＼　　　　ヽ　　　　　　　　ヽ ｀、
　　　　　　　　/　　　　　　　　　ー-、　　　　　　＼　 　　 ｀、
　　　　　　　 /　 　ヽヾヽ＼　ヽ＼　　ヽ、　　　　　　　　　　、
　　　　　　　//　/ 　|＼　　　　　　ヽ、　　 ヽ　ヽ　　|　　　l｀、
　　　　　　 / |　 | 　 l　, 、＼＼＼＼　　　　　　 ＼　 |　　 l 丶
　　 　　　　| ｌ 　 |. 　 、!　＼　＼　ー '''' ヽ、ヽ 　 　 l　 |　　|　`
.　　　　　　|.ｌ　　|　　ｒ'｝　、　＼,,、　 、__,,、-‐''｀ヽ　　|　|　　|　 |
　　　　　　 l.ｌ　　|　 （ {　　｀ー''丶 　 '''ー- '´　 |/ヽ |　| | ii 　|
　　　　 　　 l 　　|　 ヽ;　　　　　 |　 　　　 　　 |'　ｉ| l　| | |　 i
　　　　　　　ヽ　　.l 　 ｀i.　　　　 i　　　　　　　ノ, / / /// 　/　　 　　　＿＿＿＿＿＿＿＿＿＿
　　　　 　　　 ＼.　l　 　ヽ.　　 　ヽ　　　 　　/｀"　/ //　|~ヽ 　　　 ／
　　　　　　　　　 ヽ.　 　　ヽ　　_,,,,,,_　 　 　/r、　／ /　　|　　 |　 ＜またつまらぬコードを書いてしまった。
　　　　　　　　　　　＼　／llヽ　 ‐-、｀' 　 /1| ヽ　／　／|　 　|　 　 ＼＿＿＿＿＿＿＿＿＿＿
　　　　　　　　　　　　／　 ||∧. 　 　 　／ | |　 ＼-‐' 　 |　 　|
　　　　　　　 _ ,、 -／l　　 ||{　ヽ,,,,,,,,,／　 .| |　　　|ヽ、、　|　 　|
　　　 _,、- ' ´　　　　|.　　 ||｛　　　　　 　　| |　　　|ヽ、　゛|　 　|、,,_

関連記事


FizzBuzz問題から学ぶモナド
http://d.hatena.ne.jp/zecl/20110711/p1



上記記事で利用しているモナドもIdentityモナド。