Listモナドで非決定性計算

Listモナドを使うと、SICPのamb評価器が行うような非決定性計算ができる。

たとえば、ピタゴラス数を列挙するコードは次のように書ける。

-- ptriples.hs
import Control.Monad  -- guard関数を使うため

ptriples = do
    a <- [1..]
    b <- [1..a]     -- b <= a
    c <- [a..a+b]   -- c を斜辺とすれば a <= c かつ三角不等式より c <= a+b
    guard (a*a + b*b == c*c)
    return (b,a,c)  -- 小さい数から並べる

main = mapM_ print ptriples

$ runghc ptriples.hs
(3,4,5)
(6,8,10)
(5,12,13)
...

これは、次のPythonコードとほぼ同じように動作する。

# -*- coding: utf-8 -*-
# ptriples.py
import itertools

def ptriples():
    for a in itertools.count(1):  # 無限リスト [1..] に相当
        for b in xrange(1,a):
            for c in xrange(a,a+b):
                if a*a + b*b == c*c:
                    yield (b,a,c)

if __name__ == '__main__':
    for x in ptriples():
        print x

$ python ptriples.py
(3, 4, 5)
(6, 8, 10)
(5, 12, 13)
...

Haskellのコードはa,b,cの取りうる値を候補として変数のように書くことができ、より宣言的な見た目となっている。

仕組み

まず、最初に示したコードのdo記法を、本来のモナドの記法に置き換えてみる。

ptriples = 
    [1..] >>= (\a ->
    [1..a] >>= (\b ->
    [a..a+b] >>= (\c ->
    guard (a*a + b*b == c*c) >>= (\x ->
    return (b,a,c)
    ))))

ここで、Haskell 2010におけるListモナドの定義を見てみる。

 instance  Monad []  where  
    m >>= k          = concat (map k m)  
    return x         = [x]  
    fail s           = []

すなわち、returnは要素をリストに入れ、bindはリストmの各要素に対して、関数kを適用した結果を結合する。 複数回重ねた場合は、下記のようにそれぞれの組み合わせについて計算が進む。

do a <- [1,2,3]; b <- [4,5]; return (a,b)
== [1,2,3] >>= (\a -> [4,5] >>= (\b -> return (a,b)))
== concat (map (\a -> [4,5] >>= (\b -> return (a,b))) [1,2,3])
== concat [[4,5] >>= (\b -> return (1,b)), [4,5] >>= (\b -> return (2,b)), [4,5] >>= (\b -> return (3,b))]
{-
[4,5] >>= (\b -> return (1,b))
== concat (map (\b -> return (1,b)) [4,5])
== concat [return (1,4), return (1,5)]
== concat [[(1,4)], [(1,5)]]
== [(1,4), (1,5)]
-}
== concat [[(1,4), (1,5)], [(2,4), (2,5)], [(3,4), (3,5)]]
== [(1,4), (1,5), (2,4), (2,5), (3,4), (3,5)]

次に、guard関数について定義を調べる。

class Monad m => MonadPlus m where
    Monads that also support choice and failure.

    Methods
    mzero :: m a
        the identity of mplus. It should also satisfy the equations
         mzero >>= f  =  mzero  
         v >> mzero   =  mzero

    mplus :: m a -> m a -> m a
        an associative operation 

instance MonadPlus [] 

guard :: MonadPlus m => Bool -> m ()
    guard b is return () if b is True, and mzero if b is False. 

guardは一つの引数を取り、TrueであればUnit (())を値に持つモナドを、Falseならmzeroを返す。 さらに、mzeroに対してbindで関数を与えた結果は、常にmzeroになる。 つまり、一度guardに与えた式がFalseとなると、その後のbindで繋がる計算の結果はmzeroになる。

Listモナドにおけるmzeroは仕様では明記されていないが、GHCの実装では空リストとなっている。

instance MonadPlus [] where
   mzero = []
   mplus = (++)

つまり、下記のようにguardの引数が真となるものだけが残る。

do a <- [1,2,3]; guard (a <= 2); return a
== [1,2,3] >>= (\a -> guard (a <= 2) >>= (\b return a))
== concat (map (\a -> guard (a <= 2) >>= (\b return a)) [1,2,3])
== concat [guard (1 <= 2) >>= (\b return 1), guard (2 <= 2) >>= (\b return 2), guard (3 <= 2) >>= (\b return 3)]
== concat [[()] >>= (\b return 1), [()] >>= (\b return 2), [] >>= (\b return 3)] -- return () == [()]
{-
[()] >>= (\b return 1)
== concat (map (\b return 1) [()])
== concat [return 1]
== concat [[1]]
== [1]
[] >>= (\b return 3)
== concat (map (\b return 3) [])
== concat []
== []
-}
== concat [[1], [2], []]
== [1,2]

以上より、最初に示したコードはguardで示した条件を満たすもののリストを返すものとなる。

適用例

原始ピタゴラス数

最初のコードにaとbが互いに素であるという条件を加えれば、原始ピタゴラス数の列挙になる。 もっとも、原始ピタゴラス数は公式を用いて列挙できるので、公式から求めたほうが計算は速い。

-- ptriples2.hs
import Control.Monad  -- guard関数を使うため

ptriples = do
    a <- [1..]
    b <- [1..a]     -- b <= a
    c <- [a..a+b]   -- c を斜辺とすれば a <= c かつ三角不等式より c <= a+b
    guard (a*a + b*b == c*c && gcd a b == 1)
    return (b,a,c)  -- 小さい数から並べる

main = mapM_ print ptriples

$ runghc ptriples2.hs
(3,4,5)
(5,12,13)
(8,15,17)
...

SEND + MORE = MONEY

• http://en.wikipedia.org/wiki/Verbal_arithmetic

日本語では覆面算というらしい。

-- money.hs
import Control.Monad
import Data.List

money = do
    let digits = [0..9]
    s <- digits
    e <- digits \\ [s,0]
    n <- digits \\ [s,e]
    d <- digits \\ [s,e,n]
    m <- digits \\ [s,e,n,d,0]
    o <- digits \\ [s,e,n,d,m]
    r <- digits \\ [s,e,n,d,m,o]
    y <- digits \\ [s,e,n,d,m,o,r]
    let toint xs = foldl1 ((+) . (10 *)) xs
    let [send, more, money] = map toint [[s,e,n,d], [m,o,r,e], [m,o,n,e,y]]
    guard (send + more == money)
    return (send, more, money)

main = mapM_ print money

$ time runghc money.hs
(9567,1085,10652)

real    0m41.404s
user    0m35.934s
sys     0m5.064s

multiple-dwelling

SICPで非決定性計算の例として取り上げられている論理パズル。

• Baker, Cooper, Fletcher, Miller, Smithの5人が5階建てのアパートの各フロアに住んでいる。
• Bakerは5階ではない。
• Cooperは1階ではない。
• Fletcherは1階でも5階でもない。
• MillerはCooperより上の階である。
• SmithはFletcherの上下の階ではない。
• FletcherはCooperの上下の階ではない。
• それぞれ何階に住んでいるか？

-- dwelling.hs
import Control.Monad
import Data.List

dwelling = do
    [baker, cooper, fletcher, miller, smith] <- permutations [1..5]
    guard (baker /= 5 && cooper /= 1 && fletcher `notElem` [1,5])
    guard (miller > cooper)
    guard (abs(smith - fletcher) /= 1 && abs(fletcher - cooper) /= 1)
    return [("baker", baker),
            ("cooper", cooper),
            ("fletcher", fletcher),
            ("miller", miller),
            ("smith", smith)]

main = mapM_ print dwelling

$ runghc dwelling.hs
[("baker",3),("cooper",2),("fletcher",4),("miller",5),("smith",1)]