Freeモナドを使っている方、あるいはこれから使う方へ

FreeモナドのベースとなるFunctorは、GHCのDeriveFunctor拡張を使って、対象のデータ型にderiving Functorをつけることで

自 動 生 成

できます。

例

{-# LANGUAGE DeriveFunctor #-}
import Control.Monad.Free

data CharIOBase a = GetCh (Char -> a) | PutCh Char a | EmbedIO (IO a) deriving Functor

type CharIO = Free CharIOBase

とすると、

https://github.com/ghc/ghc/blob/ghc-7.6.2-release/compiler/typecheck/TcGenDeriv.lhs#L1407 の規則に従い、

instance Functor CharIOBase where
    fmap f (GetCh g) = GetCh (f . g)
    fmap f (PutCh c a) = PutCh c (f a)
    fmap f (EmbedIO m) = EmbedIO (fmap f m)

のようなインスタンスが生まれます。

Freeモナドでゲームを作ろう！第2回: 本当に動かす

連載目次

Haskellの力を最大限に引き出す

前回紹介したような関数の組み合わせでももちろんゲームは作れるのですが、今回は、さらにゲームを開発しやすくするための手法をいくつか紹介し、その例を実際に動かしてみます。

Vec2

2Dゲームを作る上でベクトルの演算は必須です。vectというライブラリは、二次元から四次元までの範囲でベクトルや行列の操作ができる、非常に便利なライブラリです。二次元に絞って主要な関数をいくつか紹介しておきます。 Edward Kmettさんから「linearを使った方がいい」といったアドバイスを頂いたので、free-game 0.9ではlinearを採用しました。零次元から四次元までの範囲でベクトルや行列の操作ができる、非常に便利なライブラリです。二次元に絞って主要な関数をいくつか紹介しておきます。

V2 :: a -> a -> V2 a -- コンストラクタ

zero :: V2 a -- 零ベクトル
negated :: V2 a -> V2 a -- 反転
(^+^) :: V2 a -> V2 a -> V2 a -- 加算
(^-^) :: V2 a -> V2 a -> V2 a -- 減算
(*^) :: a -> V2 a -> V2 a -- スカラー倍
(^*) :: V2 a -> a -> V2 a -- スカラー倍

norm :: V2 a -> a -- ベクトルのノルム(長さ)
dot :: V2 a -> V2 a -> a -- ベクトルの内積
normalize :: V2 a -> V2 a -- 方向が同じの単位ベクトル

distance :: V2 a -> V2 a -> V2 a -- 二つのベクトル間の距離を求める

Stateモナド

ご存知の方も多いと思いますが、Stateモナドは状態を扱うためのモナドで、計算の任意のタイミングで「内部状態」を変更することができます。ゲームに状態はつきものなので、そういったプログラムと相性が良いです。

Lens

Lensはlensというライブラリで定義されている型で、これを使うことで、データ型の要素の一つに着目して操作することが可能となります。まさにレンズのように！

実際に見てもらった方が早いでしょう。

{-# LANGUAGE ImplicitParams, TemplateHaskell #-}
import Graphics.UI.FreeGame
import Control.Monad.State
import Control.Lens

data Hoge = Hoge {
    _xOfHoge :: Float
    ,_yOfHoge :: Float
    ,_dxOfHoge :: Float
    ,_dyOfHoge :: Float
    }

makeLenses ''Hoge -- TemplateHaskellを用いて対応するLensを自動生成(!)

main = do
    bmp <- loadBitmapFromFile "HaskellLogoStyPreview-1.png"
    let ?pic = bmp
    _ <- runGame def $ runStateT hoge $ Hoge 80 80 3.7 1.1
    return ()

hoge :: (?pic :: Bitmap) => StateT Hoge Game ()
hoge = do
    x <- use xOfHoge
    y <- use yOfHoge
    dx <- use dxOfHoge
    dy <- use dyOfHoge

    translate (V2 x y) (fromBitmap ?pic)

    xOfHoge += dx
    yOfHoge += dy

    tick
    hoge

Q.これは手続き型言語ですか？

A.はい、関数型言語です

使い方はとっても簡単。

  • フィールド名が_で始まるようなデータ型Tを定義します
  • makeLenses ''Tします
  • Tを状態とするStateモナドの中で、
  • useで値を取得します
  • .=で値を代入します

これだけで手続き型言語の便利さを取り入れた強力なプログラミングができるようになります！すごい！

さっきのコードをVec2を使った形に直し、さらに壁に反射するようにしてみましょう。(pack.pngはhttp://botis.org/shared/pack.pngからダウンロードしてください)

{-# LANGUAGE ImplicitParams, TemplateHaskell #-}
import Graphics.UI.FreeGame
import Control.Monad.State
import Control.Applicative
import System.Random
import Control.Lens

data Pack = Pack {
    _packPos :: V2 Float
    ,_packVel :: V2 Float
    }

makeLenses ''Pack

main = do
    bmp <- loadBitmapFromFile "pack.png"
    let ?picPack = bmp
        ?packSize = 30
    pack <- Pack <$> (V2 <$> randomRIO (?packSize, 640 - ?packSize) <*> randomRIO (?packSize, 480 - ?packSize))
                 <*> ((^*4) <$> unitV2 <$> randomRIO (0, 2*pi))

    runGame def $ runStateT updatePack pack
    return ()

updatePack :: (?picPack :: Bitmap, ?packSize :: Float) => StateT Pack Game ()
updatePack = do
    pos@(V2 x y) <- use packPos
    vel <- use packVel

    let collisions = [V2 0 y | x < ?packSize]
            ++ [V2 640 y | x > 640 - ?packSize]
            ++ [V2 x 0 | y < ?packSize]
            ++ [V2 x 480 | y > 480 - ?packSize]

    translate (V2 240 240) (fromBitmap ?picPack)
    
    packVel += sum [2 *^ n
        | t <- collisions
        ,let u = normalize (t ^-^ pos)
        ,let n = dot u vel *^ negated u]

    use packVel >>= (packPos +=)

さて、壁で反射する物体を見て、あるゲームを想像した方も多いと思いますが、この連載ではそれとは一味違うゲームを作っていきます。続きはまた次回。

まとめ

  • linearは超便利
  • lensは超便利

Freeモナドでゲームを作ろう！第1回: Gameモナドの基本

連載目次

free-gameを使う

さて、みなさん、free-gameはインストールしましたか？まだの型方も、もうインストールした方も、本日free-gameを更新したのでcabal update && cabal install free-gameしましょう。 2013/5/6: free-game 0.9.3をリリースし、内容も改訂しました。必ずcabal update && cabal install free-gameしてください。

free-gameは、Gameモナドという独自のモナドによってGUIの抽象化を実現しています。GameはFreeモナドによって生成されたモナドであり、元は単なるFunctorです(これが何を意味するかは、連載の中で明らかにしていきます)。

今回は、実際にプログラムを組みながら、どのようにしてfree-gameを扱うかを学んでいきましょう。

Hello, world!

まずはHello, world!ですね。最初に、https://github.com/fumieval/free-game/blob/master/examples/VL-PGothic-Regular.ttf からフォントをダウンロードしましょう。

helloworld.hs:

{-# LANGUAGE ImplicitParams, OverloadedStrings #-}

import Graphics.UI.FreeGame

main = do
    font <- loadFont "VL-PGothic-Regular.ttf"
    let ?font = font
    runGame def mainLoop

mainLoop :: (?font :: Font) => Game a
mainLoop = do
    translate (V2 40 240) $ colored black $ text ?font 30 "Hello, Free World!" 
    tick
    mainLoop

$ ghc helloworld.hs
$ ./helloworld (Windowsの場合は単にhelloworld.exe)

このように表示されれば成功です。FreeType Errorが表示された場合、カレントディレクトリにダウンロードしたフォントがあるかどうかもう一度確認してください。

f:id:fumiexcel:20130110163026p:plain

このプログラムの肝は、Gameモナドを実行するrunGame :: GUIParam -> Game a -> IO (Maybe a)と、Picture型の値を画面に表示する関数、drawPicture :: Picture -> Game ()です。画面を更新するアクション、tick :: Game ()です。

Picture型の定義を見てみましょう。

*** この型は削除されました
data Picture
    -- ビットマップ(後述)をPictureとして使う
    = BitmapPicture Bitmap
    -- 複数のPictureをまとめて一つのPictureにする。
    | Pictures [Picture]
    -- IOモナドに入ったPicture(内部実装のためのもの)。
    | IOPicture (IO Picture)
    -- Pictureを回転する。
    | Rotate Float Picture
    -- Pictureを拡大・縮小する。
    | Scale Vec2 Picture
    -- Pictureを移動する。
    | Translate Vec2 Picture
    -- Pictureに色を付ける。
    | Colored Color Picture

実はこれはglossにインスパイアされたものです。わかりやすいでしょう？*1

free-game 0.9では、Picture2DおよびFigure2Dという型クラスが定義されています。Gameモナドはこれらのインスタンスであるため、以下のような操作が利用できます。

class Picture2D p where
    -- ビットマップから生成する
    fromBitmap :: Bitmap -> p ()
    -- 指定した角度だけ回転させる
    rotate :: Float -> p a -> p a
    -- 拡大・縮小する
    scale :: V2 Float -> p a -> p a
    -- 平行移動する
    translate :: V2 Float -> p a -> p a
    -- 色を付ける
    colored :: Color -> p a -> p a

class Picture2D p => Figure2D p where
    -- 線
    line :: [V2 Float] -> p ()
    -- 多角形
    polygon :: [V2 Float] -> p ()
    -- 多角形(枠のみ)
    polygonOutline :: [V2 Float] -> p ()
    -- 円
    circle :: Float -> p ()
    -- 円(枠のみ) 
    circleOutline :: Float -> p ()
    -- 太さを設定
    thickness :: Float -> p a -> p a

V2は、vectというライブラリで定義されている、二次元のベクトルを表すデータ型です。が、具体的な使い方はまた次回。

ビットマップはloadBitmapFromFile :: FilePath -> IO Bitmapで読み込むことができます。http://www.haskell.org/wikiupload/4/4a/HaskellLogoStyPreview-1.pngを表示してみましょう(カレントディレクトリに保存してください)。当然ながら、loadBitmapFromFileはGameモナドの中では実行できないので注意してください。Gameモナドの中でIOアクションを使いたいときは、embedIO :: IO a -> Game aを適用しましょう。

{-# LANGUAGE ImplicitParams #-}

import Graphics.UI.FreeGame
import System.Random

main = do
    font <- loadFont "VL-PGothic-Regular.ttf"
    bmp <- loadBitmapFromFile "HaskellLogoStyPreview-1.png"
    let ?font = font
    let ?bmp = bmp
    runGame def mainLoop

mainLoop :: (?bmp :: Bitmap, ?font :: Font) => Game a
mainLoop = do
    translate (V2 40 240) $ colored black $ text ?font 30 "Hello, Free World!" 
    translate (V2 240 480)
        $ rotate 45 -- 反時計回りに45°回転
        $ colored red -- 赤色
        $ text ?font 70 "真っ赤な誓いいいいいいいいいい"

    r <- randomness (-40, 40)
    translate (V2 (-40) (360 + r)) -- ランダムに振動させる
        $ scale (V2 0.7 1) -- x方向に0.7倍
        $ colored blue -- 青色
        $ text ?font 100 (replicate 20 'ド')
    translate (V2 300 300) $ colored magenta $ circle 40 -- 円を表示
    translate (V2 240 80) $ fromBitmap ?bmp -- 読み込んだビットマップを(240,80)に表示
    tick
    mainLoop

f:id:fumiexcel:20130110195629p:plain

入力を行う

これだけでは、ゲームを表現するのに不十分です――「入力」ができないからです。free-gameでは、入力を行うためにKeyboardとMouseという二つのインターフェイスを提供しています。Gameモナドはこれらのインスタンスであるため、直に以下のアクションを実行できます。

-- | The class of types that can handle inputs of the keyboard.
class Keyboard t where
    keyChar :: Char -> t Bool
    keySpecial :: SpecialKey -> t Bool

-- | The class of types that can handle inputs of the mouse.
class Mouse t where
    mousePosition :: t (V2 Float)
    mouseWheel :: t Int
    mouseButtonL :: t Bool
    mouseButtonM :: t Bool
    mouseButtonR :: t Bool

引数に指定するキーについては、http://hackage.haskell.org/packages/archive/free-game/0.9.1/doc/html/Graphics-UI-FreeGame-Base.html#t:SpecialKeyを参照してください。

例: Zキーを押している間だけカウントアップを行う。Escキーを押すとプログラムが終了する

{-# LANGUAGE ImplicitParams #-}

import Graphics.UI.FreeGame
import System.Random
import Control.Monad

main = do
    font <- loadFont "VL-PGothic-Regular.ttf"
    let ?font = font
    runGame def (mainLoop 0)

mainLoop n = do
    translate (V2 40 120) $ colored green $ text ?font 20 $ show n

    translate (V2 40 240) $ colored black $ text ?font 20 "Hello, Free World!" 

    key <- keySpecial KeyEsc -- Escキーの状態を取得
    when key quit -- Trueならば終了
    
    key <- keyChar 'Z' -- Zキーの状態を取得
    tick
    mainLoop $ if key then succ n else n -- Trueのときだけ1増やす

mousePosition, mouseWheel, mouseButtonL, mouseButtonR, mouseButtonMを使うことで、位置、ホイール、ボタンの状態が取得できます。

例: カウンタがマウスカーソルの右上に表示され、左クリックするたびに値が1ずつ増える

{-# LANGUAGE ImplicitParams #-}

import Graphics.UI.FreeGame
import System.Random
import Control.Monad

main = do
    font <- loadFont "VL-PGothic-Regular.ttf"
    let ?font = font
    runGame def $ mainLoop (0, False)

mainLoop (n, btn) = do
    pos <- mousePosition
    b <- mouseButtonL
    translate pos $ colored green $ text ?font 20 $ show n

    translate (V2 40 240) $ colored black $ text ?font 20 "Hello, Free World!" 

    tick
    mainLoop (if not btn && b then n + 1 else n, b)

drawPicture、askInput、getMouseStateの使い方が分かりましたね。実はfree-gameの基本はこれで全部なのです！

ゲームを開発する準備は整いました。次回は、これらを踏まえて実際にゲームを作ってみましょう！

まとめ

  • 基本はdrawPicture、getButtonState、getMouseStateの3つだけ
  • embedIOがあるからIOだって使えるぞ
  • runSimpleですべてが動きだす

Tips

今回の例では、GHC拡張のImplicitParamsを使っています。?のついた変数は、一旦束縛すればスコープ内で呼び出した関数からどこでも参照できるようになるので、フォントや画像データなどの不変なものを扱うのに適しています。

*1:生意気にもnice data typeを標榜するだけある

Freeモナドでゲームを作ろう！第0回: 概要

連載目次

先ほど、free-gameというライブラリをアップロードしました。free-gameは、世界で一番柔軟かつ簡単にゲームなどのGUIを作れるライブラリを目指しています。

Freeモナドとは

Freeモナドは、Functorを与えると自動的にモナドを生成してくれる構造で、これを使うことで、アクションをデータの一つとして柔軟に扱えるようになります。去年の10月ごろからにわかに日本のHaskeller間で流行り始めた、今一番熱いモナドです[要出典]。Freeモナドそのものに関してはこれらの記事を読みましょう。

free-gameの軌跡

私はしばらく前から、Haskellでゲームを作るためのライブラリとしてglossを推していたのだが…

glossの仕様に結構不満を抱いていた。

そんなある日、私はFreeモナドと出会う。

そして私は、その記述力をゲーム開発に生かそうとライブラリの開発に取り掛かった。

そして…ついにプロトタイプが完成した。

紆余曲折を経てOpenGLに対応し、今のfree-gameができたのである。

今なら胸を張って言える。「Haskellでゲームを作るならfree-game！」と。

インストール

cabal update
cabal install free-game

これだけ。

補足

  • Windows環境においてLexical Errorが発生した場合、set LANG=Cとしてからリトライするとうまくいく。
  • Ubuntuに入れる際に必要になったもの: libgl-mesa-dev, libglu1-mesa-dev, zlib1g-dev, libxrandr-dev

次回から、free-gameでどのようにしてゲームを作るのかをコードを交えて解説していきたいと思います。

究極のモナド「Idealモナド」を垣間見る(続/その0)

前回の記事究極のモナド「Idealモナド」を垣間見るではFreeモナドを構成して興奮して終わってしまったが、今回はイデアルモナドの仕組みについてもう少し考えてみる。

data Ideal f a = Pure a | Ideal (f a)

Idealモナドは、純粋な値Pure aか、fというなにかに包まれているIdeal (f a)のどちらかを取る、という仕組みになっている。returnはPureに、何らかの作用を持つアクションはIdealに行く─純粋かそうでないかを分離することが、イデアルモナドの本質を表しているのかもしれない。

例示は理解の試金石*1という言葉を信じて、実際にいくつかモナドを構成してみよう。

Ideal型とIdealizeクラスについて、以下のような定義がなされているものとする。

import Control.Monad
import Control.Applicative

data Ideal f a = Pure a | Ideal (f a)

class Idealize f where
    (>>~) :: f a -> (a -> Ideal f b) -> f b

instance Idealize f => Monad (Ideal f) where
    return = Pure
    Pure a >>= k = k a
    Ideal fa >>= k = Ideal (fa >>~ k)

Identity

data Empty a

instance Idealize Empty where
    (>>~) = undefined

type Identity = Ideal Empty

runIdentity (Pure a) = a

Maybe, Either

instance Idealize (Const a) where
    Const a >>~ _ = Const a

type Maybe = Ideal (Const ())
nothing = Ideal (Const ())

maybe _ f (Pure a) = f a
maybe v _ (Ideal (Const ())) = v

type Either a b = Ideal (Const b) a

left = Ideal . Const
right = Pure

either f g (Pure b) = g b
either f g (Ideal (Const a)) = f a

Reader

type Reader r = Ideal ((->) r)
 
instance Idealize ((->) r) where
    f >>~ k = \r -> runReader (k $ f r) r
 
ask = Ideal id

runReader (Pure a) _ = a
runReader (Ideal f) r = f r

二つの計算に同じ環境を与えることがReaderの本質なので、そういった意味ではわかりやすいかもしれない。

Writer

instance Monoid w => Idealize ((,) w) where
    (w, a) >>~ k = let (b, w') = runWriter (k a) in (mappend w w', b)

type Writer w = Ideal ((,) w)

tell w = Ideal (w, ())

runWriter (Pure a) = (a, mempty)
runWriter (Ideal (w, a)) = (a, w)

State

newtype StateBase s a = StateBase (s -> (a, s))

instance Idealize (StateBase s) where
    StateBase f >>~ k = StateBase $ \s -> let (b, s') = f s in runState (k b) s'

type State s = Ideal (StateBase s)

runState (Pure a) s = (a, s)
runState (Ideal (StateBase f)) s = f s

get = Ideal $ StateBase (\s -> (s, s))

put s = Ideal $ StateBase (\_ -> ((), s))

modify f = Ideal $ StateBase (\s -> ((), f s))

なるほど、「(>>~)で純粋な場合の挙動とそうでない場合の挙動を記述すればMonadを作ってくれる*2」ということか。普通にMonadを作ったときと複雑さが変わらないような気もする…(FunctorとかApplicativeを自分で宣言しなくてよいのは楽だが)。

次回は、Idealの汎用性についてもう少し考えてみる。

*1:結城浩著「数学ガール」より

*2:>>~は私が前回定義した、イデアルモナドを構成するのに最低限必要な演算

究極のモナド「Idealモナド」を垣間見る

新年おめでとうございます。

突然だが、中身への関数適用(fmap)、シングルトンの生成(return)、ネストの結合(join)ができるコンテナを一般化するとモナドになる。

昨年話題になったのでご存知の方も多いと思うが、モナドをシングルトンの生成とネストの結合に関して一般化する、Freeモナドという構造がある。

さらにFreeモナドを一般化すると…Idealモナドになるのだ。

発端

イデアルモナド！？なにそれかっこいい！

そして、私の長い旅が始まる…

定義

Monads and More: Part 2によれば、

An ideal monad on C is a monad (T, η, μ) together with an endofunctor T' on C and a natural transformation μ' : T' T → T such that T = Id + T', η = inl, μ = [id, inr ◦ μ']

Tは対象のイデアルモナド、ηはreturn、μはjoin、IdはIdentity、+は直和型、inlは左のコンストラクタ、inrは右のコンストラクタに、[f, g]はeither f g的な関数に対応する。で、T'とμ'が新たに定義されるようだ。とりあえず愚直に組んでみる。

import Control.Monad

data Ideal f a = Pure a | Ideal (f a)        -- T = Id + T' 

class Functor f => Mu' f where
    mu' :: f (Ideal f a) -> f a              -- μ' : T' T → T

instance Mu' f => Monad (Ideal f) where
    return = Pure                            -- η = inl
    Pure a >>= k = k a                       -- id
    Ideal fa >>= k = Ideal $ mu' $ fmap k fa -- inr ◦ μ'

What is the correct definition of ideal monads?によれば、

  • mu' . fmap return = id :: Mu' f => f a -> f a
  • mu' . mu' = mu' . fmap join :: Mu' f => f (Ideal f (Ideal f a)) -> f a

の二つの式を満たすときイデアルモナドになる。ｺﾝﾊﾟｲﾙﾄｵｯﾀｧｧｧｧｧｗｗｗｗｗｗｗｗ

実例

これだけでは動かしようがないので、Freeモナドを構成してみよう。

newtype Liberty f a = Liberty (f (Free f a))

type Free f = Ideal (Liberty f)

instance Functor f => Functor (Liberty f) where
    fmap f (Liberty fia) = Liberty (fmap (liftM f) fia)

instance Functor f => Mu' (Liberty f) where
    mu' (Liberty fii) = Liberty $ fmap join fii

free :: Functor f => f (Free f a) -> Free f a
free f = Ideal (Liberty f)

Libertyは与えられたFunctorで包まれたFree、FreeはLibertyに対するIdealと定義する。

Freeモナド(=Ideal (Liberty f))に対するliftMとjoinを、それぞれLibertyの中身に使うことでfmapとmu'を実装している。

よし早速テスト…って、よく考えてみたらFreeモナドも単体では動かしようがないじゃないか！

実例の実例

仕方ないので、そろそろFreeモナドに関して一言いっとくかから例を引っ張り出してきた。

data CharIO a = GetCh (Char -> a) | PutCh Char a

instance Functor CharIO where
    fmap f (GetCh g) = GetCh (f . g)
    fmap f (PutCh c x) = PutCh c (f x)

getCh :: Free CharIO Char
getCh = free $ GetCh $ \ch -> Pure ch

putCh :: Char -> Free CharIO ()
putCh ch = free $ PutCh ch (Pure ())

runStdIO :: Free CharIO a -> IO a
runStdIO (Pure a) = return a
runStdIO (Ideal (Liberty (GetCh f)))       = getChar >>= \ch -> runStdIO (f ch)
runStdIO (Ideal (Liberty (PutCh ch cont))) = putChar ch >> runStdIO cont

main = runStdIO $ do
    mapM_ putCh "Hello, Haskeller! Please input a character: "
    ch <- getCh
    mapM_ putCh "The ordinal of the character is: "
    mapM_ putCh (show (ord ch))
    mapM_ putCh ".\nThank you!\n"

早速実行してみる。

Prelude> main
Hello, Haskeller! P(メモリをすごい勢いで消費しつつだんだん遅くなる)

理由は簡単だった。(>>=)はfmapとmu'を呼び出し、そのfmapとmu'はliftM、join経由で(>>=)を呼び出していたのだ！これでは組み合わせおねえさんめいて計算量が爆発四散してしまう！

2013/3/5追記: IdealをFunctorのインスタンスにし、Liberty (fmap (liftM f) fia)の代わりにLiberty (fmap (fmap f) fia)とすれば問題なく実行できる。

融合と本質

一つにしてしまえばこの問題は起こらないはずなので、fmapとmu'の機能を併せ持つ(>>~)を使うようにした。

class Idealize f where
    (>>~) :: f a -> (a -> Ideal f b) -> f b

instance Idealize f => Monad (Ideal f) where
    return = Pure
    Pure a >>= k = k a
    Ideal fa >>= k = Ideal $ fa >>~ k

newtype Liberty f a = Liberty (f (Free f a))

type Free f = Ideal (Liberty f)

instance Functor f => Idealize (Liberty f) where
    Liberty fm >>~ k = Liberty (fmap (>>=k) fm)

free :: Functor f => f (Free f a) -> Free f a
free f = Ideal (Liberty f)

おっと！？

おわかりいただけただろうか…Idealizeのインスタンス宣言をもう一度よく見て欲しい。

Liberty fm >>~ k = Liberty (fmap (>>=k) fm)

普通のFreeモナドの定義を思い出してみよう。

data Free f a = Pure a | Free (f (Free f a))

instance Functor f => Monad (Free f) where
    return = Pure
    Pure a >>= k = k a
    Free fm >>= k = Free (fmap (>>=k) fm)

そう、まさに(>>~)の定義は、Freeモナドをモナドたらしめる最も重要な式、Free fm >>= k = Free (fmap (>>=k) fm)と同じなのである！

無事に定義ができたので、早速動かしてみよう。

Prelude> main
Hello, Haskeller! Please input a character: m
The ordinal of the character is: 109.
Thank you!

当たり前だが、動いた！感動した！これが…モナドの力なのか…

まとめ

Freeのさらなる一般化、Ideal。抽象的すぎて実用性があるのかどうかわからないが、大変興味深い構造である。今のところ、Hackage上にIdealモナドを扱うパッケージはない(以前はあったが廃止されたようだ)ので、あとでアップロードするかもしれない。

この記事で使用したソースコードはhttps://gist.github.com/4445447にある。

Freeモナド実用の旅(5): MonadPlus for Free

Control.MonadPlus.Freeはいなくなりました

えにっきをみてください

freeの新バージョンにControl.MonadPlus.Freeなるものがあったのでさっそく使ってみた。MonadPlus版Freeのコンストラクタは、Pure、Freeに加えて新たにPlusが加わっており、任意のFunctorからMonadPlusなモナドを生成することができる。

以下は、Freeモナドによって錬成されたパーサコンビネータの例。

import Control.Monad
import Control.MonadPlus.Free
import Control.Applicative
import Data.Char

data ParseStep a = ParseStep (Maybe Char -> Maybe a)

instance Functor ParseStep where
    fmap f (ParseStep g) = ParseStep (fmap f . g)

type Parser = Free ParseStep

runParser :: Parser a -> String -> Maybe a
runParser (Pure a) "" = Just a
runParser (Pure _) _ = Nothing
runParser (Free (ParseStep f)) str = case str of
    []     -> f Nothing  >>= flip runParser []
    (x:xs) -> f (Just x) >>= flip runParser xs
runParser (Plus xs) str = msum $ map (flip runParser str) xs -- ここがポイント！

anyChar :: Parser Char
anyChar = liftF (ParseStep id)

satisfy :: (Char -> Bool) -> Parser Char
satisfy f = do
    ch <- anyChar
    if f ch then pure ch else empty

char :: Char -> Parser Char
char ch = satisfy (==ch)

string :: String -> Parser String
string str = mapM char str

digit :: Parser Int
digit = digitToInt <$> satisfy isDigit

natural :: Parser Int
natural = foldl ((+) . (*10)) 0 <$> some digit

parens :: Parser a -> Parser a
parens p = char '(' *> p <* char ')'

chainl :: Parser a -> Parser (a -> a -> a) -> Parser a
chainl p op = p >>= rest where
    rest x = (op <*> pure x <*> p >>= rest) <|> return x

spaces :: Parser a -> Parser a
spaces p = many (char ' ') *> p <* many (char ' ')

fact :: Parser Int
fact = parens expr <|> natural

term :: Parser Int
term = chainl fact $ spaces
    $ char '*' *> return (*)
    <|> char '/' *> return div

expr :: Parser Int
expr = chainl term $ spaces
    $ char '+' *> return (+)
    <|> char '-' *> return (-)

main = do
    let ev = runParser expr
    print $ ev "42"                 -- Just 42
    print $ ev "1 + 1"              -- Just 2
    print $ ev "1 - (2 - 3)"        -- Just 2
    print $ ev "(1 - 2) - 3"        -- Just (-4)
    print $ ev "1 - 2 - 3"        -- Just (-4)
    print $ ev "2 * (3 + 5)"        -- Just 16
    print $ ev "(5 * 6 - 10) / 4"   -- Just 5
    print $ ev "1 + "               -- Nothing

やっぱりFreeモナドはすごい。