Prev: モナド変換子の解剖 TOC: 目次 Next: 変換子スタックの管理

さらにモナド変換子の例


ここでは、プログラムでモナドおよびモナド変換子を使いはじめるのに必要な ことはすべて判っているはずです。熟練のための最良の方法は、実際のコードを 書いてみることです。自分で書いたモナドを使ったプログラムが大がかりになる ほど、合成されたモナドに変換子を混ぜいれるのがやっかいになってくるのが わかるでしょう。このことについては次節で扱いますが、まずは、単一の 変換子をベースのモナドに適用する基本的なプロセスをマスターしなければ なりません。

IO と WriterT

例 17 のファイアウォールシミュレータ を調整して、それぞれのログエントリにタイムスタンプを含ませることに しましょう(エントリのマージについては心配しないでよいでしょう)。 必要な変更は以下のようなものです。

example22.hs で使えるコード
-- これはログエントリのフォーマット
data Entry = Log {timestamp::ClockTime, msg::String} deriving Eq

instance Show Entry where
  show (Log t s) = (show t) ++ " | " ++ s

-- これは合成されたモナドの型
type LogWriter a = WriterT [Entry] IO a

-- ログにメッセージを追加
logMsg :: String -> LogWriter ()
logMsg s = do t <- liftIO getClockTime
              tell [Log t s]

-- 一パケットの処理
filterOne :: [Rule] -> Packet -> LogWriter (Maybe Packet)
filterOne rules packet = do rule <- return (match rules packet)
                            case rule of
                              Nothing  -> do logMsg ("DROPPING UNMATCHED PACKET: " ++ (show packet))
                                             return Nothing
                              (Just r) -> do when (logIt r) (logMsg ("MATCH: " ++ (show r) ++ " <=> " ++ (show packet)))
                                             case r of
                                               (Rule Accept _ _) -> return (Just packet)
                                               (Rule Reject _ _) -> return Nothing

-- パケットのリストをフィルタし、フィルタされたパケットのリストと
-- 活動ログを生成
filterAll :: [Rule] -> [Packet] -> LogWriter [Packet]
filterAll rules packets = do logMsg "STARTING PACKET FILTER"
                             out <- mapM (filterOne rules) packets
                             logMsg "STOPPING PACKET FILTER"
                             return (catMaybes out)

-- 第一引数のファイル名のファイルからルールデータを読み、
-- 第二引数のファイル名のファイルからパケットデータを読み、
-- 受け入れたパケットを印字し、計算中のログを生成
main :: IO ()
main = do args       <- getArgs
          ruleData   <- readFile (args!!0)
          packetData <- readFile (args!!1)
          let rules   = (read ruleData)::[Rule]
              packets = (read packetData)::[Packet]
          (out,log) <- runWriterT (filterAll rules packets)
          putStrLn "ACCEPTED PACKETS"
          putStr (unlines (map show out))
          putStrLn "\n\nFIREWALL LOG"
          putStr (unlines (map show log))

IO と ReaderT

上の例がやさしすぎると思うなら、もう少し複雑な例を見てください。 例 16 のテンプレートシステムを 名前のついた複数のテンプレートがある単一のテンプレートファイルを使うもの からテンプレート毎に別々のファイルをあつかうものに変更するというものです。 一つの可能性のある解は 例 23 に示されていますが、それを 見ないでやってみてください。

List と StateT

前の例はどれも IO モナドを内部モナドとして利用していました。ここでは さらに興味深い例をみましょう。List モナドと StateT を合成 して状態をもつ非決定性計算のためのモナドを生成します。

この強力なモナド合成の手法を制約充足問題(ここでは、論理問題)に適用します。 その背景にあるアイディアは、異なる値を取りうる複数の変数と、そのような 変数を含む、充足すべき複数の述語を扱うというものです。現在の変数の割当と 述語が計算の状態であり、List モナドの非決定性が簡単に、すべての変数割当 の組合せをテストするのを可能にします。

まず、論理問題を表現するのに必要な土台を構築するところから始めます。 単純な述語言語です。

example24.hs で使えるコード
-- まず、論理問題を表現する言語を開発
type Var   = String
type Value = String
data Predicate = Is    Var Value            -- 特定の値を持つ変数
               | Equal Var Var              -- 同じ値(非特定)を持つ変数
	       | And   Predicate Predicate  -- 共に真
	       | Or    Predicate Predicate  -- すくなくともどちらかが真
	       | Not   Predicate            -- それは真ではない
  deriving (Eq, Show)

type Variables = [(Var,Value)]

-- 変数が指定した値と等しくないことをテスト
isNot :: Var -> Value -> Predicate
isNot var value = Not (Is var value)

-- a が真なら、b も真でなければならない
implies :: Predicate -> Predicate -> Predicate
implies a b = Not (a `And` (Not b))

-- 排他的 OR
orElse :: Predicate -> Predicate -> Predicate
orElse a b = (a `And` (Not b)) `Or` ((Not a) `And` b)

-- 与えられた変数束縛で述語をチェック
-- 非束縛変数があれば、Nothing
check :: Predicate -> Variables -> Maybe Bool
check (Is var value) vars = do val <- lookup var vars
                               return (val == value)
check (Equal v1 v2)  vars = do val1 <- lookup v1 vars
                               val2 <- lookup v2 vars
			       return (val1 == val2)
check (And p1 p2)    vars = liftM2 (&&) (check p1 vars) (check p2 vars)
check (Or  p1 p2)    vars = liftM2 (||) (check p1 vars) (check p2 vars)
check (Not p)        vars = liftM (not) (check p vars)

つぎに必要なのは、制約充足問題を表現し、解くためのコードです。 ここで、合成モナドを定義します。

Code available in example24.hs
-- 論理問題の型
data ProblemState = PS {vars::Variables, constraints::[Predicate]}

-- 状態のある非決定性計算のためのモナド型
type NDS a = StateT ProblemState [] a

-- 変数の検索
getVar :: Var -> NDS (Maybe Value)
getVar v = do vs <- gets vars
              return $ lookup v vs

-- 変数の設定
setVar :: Var -> Value -> NDS ()
setVar v x = do st <- get
                vs' <- return $ filter ((v/=).fst) (vars st)
                put $ st {vars=(v,x):vs'}

-- 変数割当がすべての述語を満すかをチェック
-- 引数は、述語がその中で使っている変数が未束縛であることを理由に
-- Nothing を返すときに使う値を決定する。これを True に設定すると、
-- 部分的な解を受け入れ、最後に False 値を使って、
-- 全ての解を得たことを表す。
isConsistent :: Bool -> NDS Bool
isConsistent partial = do cs <- gets constraints
                          vs <- gets vars
                          let results = map (\p->check p vs) cs
                          return $ and (map (maybe partial id) results)

-- 一貫性のある解を完成する変数束縛のみを返す。
getFinalVars :: NDS Variables
getFinalVars = do c <- isConsistent False
                  guard c
                  gets vars

-- 問題に対する最初の解を得る。そのために、ソルバ計算を初期問題状態から
-- 評価し、結果のリストの最初の解、または、解がなければ Nothing を返す。
getSolution :: NDS a -> ProblemState -> Maybe a
getSolution c i = listToMaybe (evalStateT c i)

-- 初期問題状態からソルバ計算を評価して、問題に対する可能な
-- すべての解のリストを取得する。
getAllSolutions :: NDS a -> ProblemState -> [a]
getAllSolutions c i = evalStateT c i

これで、述語言語と状態のある非決定性モナドを論理問題を解くのに適用する 準備ができました。例として有名な Kalotan パズルを使いましょう。 このパズルは、J. A. H. Hunter の Mathematical Brain-Teasers, Dover Publications (1976) という本にあります。

カロタンは奇妙な癖のある種族です。男は常に真実を語り、女はいちどきに 2 つの真実は言わない、あるいは、いちどきに 2 つの嘘は言わないというものです。

ある人類学者(彼をウォルフと呼びましょう)が彼らの研究を始めました。ウォル フはまだ、カロタンの言葉を知りません。ある日、カロタンのカップル(異性)と その子どものキビと出会いました。ウォルフはキビに「きみは男の子?」とたず ねました。キビはカロタン語で答えたので、ウォルフには分りませんでした。

ウォルフは両親(英語を知っている)に説明を求めました。ひとりが、「キビは、 自分は男の子だといっている」と言いもうひとりが、「キビは女の子。キビは嘘 をついた」と付け加えました。

この両親の性別とキビの性別をあててください。

このパズル用にいくつか述語を追加し、許可された変数値の世界を定義する 必要があるでしょう。

example24.hs で使えるコード
-- 男がなにか言うならそれは真でなければならない
said :: Var -> Predicate -> Predicate
said v p = (v `Is` "male") `implies` p

-- 男が2つのことを言うならそれらは真でなければならない
-- 女が2つのことを言うならひとつは真、もうひとつは偽でなければならない
saidBoth :: Var -> Predicate -> Predicate -> Predicate
saidBoth v p1 p2 = And ((v `Is` "male") `implies` (p1 `And` p2))
                       ((v `Is` "female") `implies` (p1 `orElse` p2))

-- 嘘をつくとは、真ではないときに真だと言うか、あるいは
-- 真であるときに、真ではないという言うこと
lied :: Var -> Predicate -> Predicate
lied v p = ((v `said` p) `And` (Not p)) `orElse` ((v `said` (Not p)) `And` p)

-- 変数の可能な設定すべてについて一貫性をテストする
tryAllValues :: Var -> NDS ()
tryAllValues var = do (setVar var "male") `mplus` (setVar var "female")
                      c <- isConsistent True
                      guard c

あとすべきことは、パズルを述語言語で記述し、すべての述語を満す 解を得ることだけです。

example24.hs で使えるコード
-- 問題を定義し、すべての変数割当を試し、解を印字する
main :: IO ()
main = do let variables   = []
              constraints = [ Not (Equal "parent1" "parent2"),
                              "parent1" `said` ("child" `said` ("child" `Is` "male")),
                              saidBoth "parent2" ("child" `Is` "female")
                                                 ("child" `lied` ("child" `Is` "male")) ]
              problem     = PS variables constraints
          print $ (`getSolution` problem) $ do tryAllValues "parent1"
                                               tryAllValues "parent2"
                                               tryAllValues "child"
                                               getFinalVars

それぞれの tryAllValues の呼び出しは解空間をフォークします。 ひとつのフォークでは名前付変数が "male" に割当てられます。 もういっぽうのフォークでは、"female" に割当てられます。 矛盾する変数割当を生成したフォークは(guard 関数で) 消去されます。getFinalVars への呼び出しは guard を再適用して、矛盾する変数割当てを消去し、 のこりの割当てを計算の値として返します。


Prev: モナド変換子の解剖 TOC: 目次 Next: 変換子スタックの管理