さらにモナド変換子の例

-- これはログエントリのフォーマット
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))

-- まず、論理問題を表現する言語を開発
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)

-- 論理問題の型
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

-- 男がなにか言うならそれは真でなければならない
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

-- 問題を定義し、すべての変数割当を試し、解を印字する
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