確率モナド

Generic Monad System の利用例として、まずはリスト・モナドの典型的な使用方法を概観します。後半で、リスト・モナドと別のモナドを合成するモナド・トランスフォーマーの実例を示したいと思います。

リスト・モナド

話を分かりやすく (?) するために、以下の二つの集合 (リスト) から無作為に元を抽出し、別の新たな集合を構成する、ということを考えます:

(define berryz '(momoko miyabi risako yurina chinami captain maasa))
(define c-ute  '(maimi erika airi kanna nakky mai chisato))

(別の新たな集合とは Buono! のことです)

リスト・モナドを用いたモナド式は次のようなものになります:

(require "list.ss")

(doM (x <- berryz)
     (y <- berryz)
     (guard (not (eq? x y)))
     (z <- c-ute)
     (guard (buono? (list x y z)))
     (return (list x y z)))

doM は Haskell の do を Scheme 用に移植したものです。これは >>= という演算子のシンタックス・シュガーで、

(>>= berryz
     (lambda (x)
       (>>= berryz
            (lambda (y)
               ...

のように、>>= 式のネストによってインデントがどんどん深くなっていくのを防ぐ目的があります。<- は「集合から (無作為に) 元を一つ抽出する」と読んでください。

guard は真偽値を取る関数で、真ならばモナド演算を先へ進めます (偽ならバックトラックを行います)。

一つ目の guard 式では、元 x と y が相異なることを保証し、二つ目では新たな集合が buono であるかどうかをチェックしています。このチェックのための述語を以下に定義していきます。

;; Reference: http://web.cecs.pdx.edu/~mpj/pubs/springschool.html
(define (subset? xs ys)
  (andmap (cut memq <> ys) xs))   ; srfi-26
(define (same-set? xs ys)
  (and (subset? xs ys) (subset? ys xs) #t))

一方が他方の部分集合である、というテストを相互に行うことで、二つのリスト (集合) が順序に関わり無く同一であることを確かめることが出来ます。

ちなみに "cut memq" の部分は "cute member" に置き換えても動作します。

これに基づいて、buono? は以下のように定義することができます:

(define (buono? xs)
  (same-set? xs '(momoko miyabi airi)))

(buono? '(airi miyabi momoko))
; => #t
(buono? '(airi miyabi reinya))
; => Aa

では改めて最初の doM 式を実行しますが、後で確率モナドで利用するために、関数にしておきます。

(define (choose-buono berryz c-ute)
  (doM (x <- berryz)
       (y <- berryz)
       (guard (not (eq? x y)))
       (z <- c-ute)
       (guard (buono? (list x y z)))
       (return (list x y z))))

(choose-buono berryz c-ute)
; => ((momoko miyabi airi) (miyabi momoko airi))

求める答えが最初から分かりきっているのであまり意味が無いように見えますが、たくさん (何百通りも) あるはずの組み合わせの中から二つだけが得られる、という点に意味があります。

一般に Scheme ではこの種の演算には "amb" というマクロを使うところです。言い換えると、リスト・モナドは非決定論演算のためのモナドとも言えます。

ただ、やはりこれだけでは得るものが少なすぎます。そこで、リスト・モナドのバックトラックの性質を生かしつつ、そこに確率の情報を付加する、という手法について見ていきましょう。

確率モナド

Random Hacks の次の記事:
http://www.randomhacks.net/articles/2007/02/21/refactoring-probability-distributions
にて、Haskell における確率モナド (Perhaps[T]) の実装が示されています。以下はこれをほぼそのまま Scheme に翻訳したものです。

perhaps.ss:

(module perhaps mzscheme
  (provide (all-from "monad.ss")

           Perhaps
           perhaps
           never

           newPerhapsT
           PerhapsT
           runPerhapsT)

  (require "monad.ss")

;;; Perhaps

  (data Perhaps)

  (define (never)
    (Perhaps 'undefined 0))

  (define perhaps Perhaps)

  (define (neverHappens ph)
    (match-data ph
      ((Perhaps _ 0) #t)
      (else #f)))

  (define (install-perhaps-monad install)
    (define (fmap f ph)
      (match-data ph
        ((Perhaps x p)
         (Perhaps (f x) p))))

    (install (lambda (op)
               (case op
                 ((return) (lambda (x)
                             (Perhaps x 1.0)))
                 ((>>=) (lambda (ph f)
                          (if (neverHappens ph)
                              (never)
                              (match-data (fmap f ph)
                                ((Perhaps (Perhaps x p1) p2)
                                 (Perhaps x (* p1 p2)))))))
                 (else #f)))))

  (install-perhaps-monad (install-monad 'Perhaps))

;;; PerhapsT

  (define (PerhapsT x)
    (((current-monad) 'PerhapsT) x))
  (define (runPerhapsT m)
    ((untype-monad (monad-type m)) m))

  (define (newPerhapsT type)
    (transform-monad 'PerhapsT type install-perhaps-t))

  (define (install-perhaps-t t m)
    (define PerhapsT (t'monadT))
    (define runPerhapsT (t'unmonadT))
    (define return (m'return))

    (let ((mt (lambda (op)
                (case op
                  ((PerhapsT) PerhapsT)
                  ((runPerhapsT) runPerhapsT)
                  (else #f)))))
      ((t'install) mt)
      ((m'install) mt))

    ((t'install)
     (lambda (op)
       (case op
         ;; Monad
         ((return) (compose (t'lift) return))
         ((>>=)
          (lambda (m f)
            (let ((bound
                   (doM (ph <- (runPerhapsT m))
                        (match-data ph
                          ((Perhaps x1 p1)
                           (if (= p1 0)
                               (return (never))
                               (doM (ph <- (runPerhapsT
                                            (with-monad (t'type)
                                              (f x1))))
                                    (match-data ph
                                      ((Perhaps x2 p2)
                                       (return
                                        (Perhaps x2 (* p1 p2))))))))))))
              (PerhapsT bound))))
         ;; MonadPlus
         ((mzero) (PerhapsT (m'mzero)))
         ;; MonadTrans
         ((lift) (lambda (x)
                   (PerhapsT (liftM ((lookup-monad 'Perhaps)
                                     'return)
                                    x))))
         (else #f)))))

  )

これに基づいて、元のプレーンなリストに確率情報をくっ付ける関数を作ることが出来ます。

(require "list.ss"
         "perhaps.ss")

(define Dist (newPerhapsT 'List))

(define (uniform xs)
  (weighted (map (lambda (x)
                   (cons x 1.0))
                 xs)))

(define (weighted xws)
  (with-monad Dist
    (if (null? xws)
        (error 'weighted "Empty probability distribution")
        (let* ((sum (foldl (lambda (xw w1)
                             (+ w1 (cdr xw)))
                           0
                           xws))
               (weight (lambda (xw)
                         (Perhaps (car xw)
                                  (/ (cdr xw)
                                     sum)))))
          (PerhapsT (map weight xws))))))

newPerhapsT がモナド・トランスフォーマーを (動的に) インストールするためのインターフェースです。Perhaps モナドと他のモナド (List) とを組み合わせた新しいモナドを作ります。返り値はシンボルです。

uniform によって、集合の各元 (事象) が等しい確率で抽出されるように重み付けをします。例えば (uniform berryz) を評価すると、

(((((momoko 0.14285714285714285) . Perhaps)
   ((miyabi 0.14285714285714285) . Perhaps)
   ((risako 0.14285714285714285) . Perhaps)
   ((yurina 0.14285714285714285) . Perhaps)
   ((chinami 0.14285714285714285) . Perhaps)
   ((captain 0.14285714285714285) . Perhaps)
   ((maasa 0.14285714285714285) . Perhaps))) . PerhapsT-List)

が得られます。

では先程の choose-buono 関数を確率付きで実行してみましょう:

(choose-buono (uniform berryz)
              (uniform c-ute))
; =>
 ((((((momoko miyabi airi) 0.0029154518950437313) . Perhaps)
    (((miyabi momoko airi) 0.0029154518950437313) . Perhaps)))
   . PerhapsT-List)

この二つの Perhaps の数値を加算したものが、集合 berryz から二人、ｃ-ute から一人を無作為に選んだ集合が偶然 buono になる確率であると思われます。

最終的に、fold 関数とパターンマッチを使って、

(foldr (lambda (ph acc)
         (match-data ph
           ((Perhaps _ p)
            (+ acc p))))
       0
       (runPerhapsT
        (choose-buono (uniform berryz)
                      (uniform c-ute))))
; => 0.005830903790087463

となりました。(合ってますかね？)

また、この手法を使うと、「三つのサイコロを転がして、出た目の和が 9 になる確率と 10 になる確率はどちらが高いか」といった古典的な確率論の問題も容易に解くことが出来ます。是非いろいろ試してみてください。