Let's write β

プログラミング中にできたことか、思ったこととか

トップ > Haskell > Haskellで論理式をパースして遊ぶ

Haskellで論理式をパースして遊ぶ

Haskell

昨日の昼ごろなんとなくパーザを書きたくなり、ちょうど論理式のパーザなんかが短時間で書くには適切なものだろうと思いまして書いてみました。Parsecのハイパワーな機能をつかってしまうことも考えたのですが、どうせならなんとなく自分で構造をくみ上げていくほうが楽しいかと思いbuilderなどの機能は使っていません。

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Control.Monad

data Expr =  Const Bool | Atom Char | And Expr Expr | Or Expr Expr | Imp Expr Expr | Iff Expr Expr | Not Expr  deriving (Show, Eq)

op :: GenParser Char st Char
op = 
   char 'v'
   <|> char '^'
   <|> char '>'
   <|> char '='

nop :: GenParser Char st Char
nop = char '~'

constTerm :: GenParser Char st Expr
constTerm = try (do char 'T' 
                    return (Const True))
        <|> try (do char 'F'
                    return (Const False))

term :: GenParser Char st Expr
term = (do
        c <- noneOf "TF()~v^>="
        return (Atom c))

expr :: GenParser Char st Expr
expr = try (do 　
                char '('
                e1 <- expr
                o  <- op
                e2 <- expr
                char ')'
                return (case o of
                        'v' -> (Or e1 e2)
                        '^' -> (And e1 e2)
                        '>' -> (Imp e1 e2)
                        '=' -> (Iff e1 e2)))
        <|> try (do 
                char '('
                nop
                ex <- expr
                char ')'
                return (Not ex))
        <|> try (do
                ct <- constTerm
                return ct)
        <|> try (do 
                t <- term 
                return t)

eos = notFollowedBy anyChar
        <?> "End of String"
        

lexpr :: GenParser Char st Expr
lexpr = try (do
                        t <- term
                        eos
                        return t)
        <|> try (do
                        t <- constTerm
                        eos
                        return t)
        <|> try (do
                        ex <- expr
                        eos
                        return ex)

parseExpr = parse lexpr "Parse Error"

expr2infix :: Expr -> String
expr2infix (And a b) = "^"++(expr2infix a)++(expr2infix b)
expr2infix (Or a b) = "v"++(expr2infix a)++(expr2infix b)
expr2infix (Not a) = "~"++(expr2infix a)
expr2infix (Imp a b) = ">"++(expr2infix a)++(expr2infix b)
expr2infix (Iff a b) = "="++(expr2infix a)++(expr2infix b)
expr2infix (Const True) = "T"
expr2infix (Const False) = "F"
expr2infix (Atom a) = [a]

expr2suffix :: Expr -> String
expr2suffix (And a b) = (expr2suffix a)++(expr2suffix b)++"^"
expr2suffix (Or a b) = (expr2suffix a)++(expr2suffix b)++"v"
expr2suffix (Not a) = (expr2suffix a)++"~"
expr2suffix (Imp a b) = ">"++(expr2suffix a)++(expr2suffix b)
expr2suffix (Iff a b) = "="++(expr2suffix a)++(expr2suffix b)
expr2suffix (Const True) = "T"
expr2suffix (Const False) = "F"
expr2suffix (Atom a) = [a]


data Assign = Assign Char Bool deriving (Show)

assignLookup :: Char -> [Assign] -> Expr
assignLookup char [] = (Atom char)
assignLookup char ((Assign k v):xs) 
        | char==k   = (Const v)
        | otherwise = assignLookup char xs

assignExpr :: [Assign] -> Expr -> Expr
assignExpr x (And a b) = (And (assignExpr x a) (assignExpr x b))
assignExpr x (Or  a b) = (Or  (assignExpr x a) (assignExpr x b))
assignExpr x (Not a)   = (Not (assignExpr x a))
assignExpr x (Atom a)  = assignLookup a x
assignExpr x a = a

evalExpr :: Expr -> Bool
evalExpr (And a b) = (evalExpr a) && (evalExpr b)
evalExpr (Or  a b) = (evalExpr a) || (evalExpr b)
evalExpr (Not a) =   not (evalExpr a)
evalExpr (Imp (Const True) (Const False)) = False
evalExpr (Imp a b) = (evalExpr (Imp (Const (evalExpr a)) (Const (evalExpr b))))
evalExpr (Iff a b) = (evalExpr a) == (evalExpr b)
evalExpr (Const a) = a

evalExprWith :: Expr -> [Assign] -> Bool
evalExprWith expr assign = evalExpr $ assignExpr assign expr

unique :: (Eq a) => [a] -> [a]
unique [a] = [a]
unique (x:xs)  = x : unique (filter (\y -> not(x==y)) xs)

atomExprs :: Expr -> [Expr]
atomExprs (And a b) = unique $ (atomExprs a)++(atomExprs b)
atomExprs (Or a b)  = unique $ (atomExprs a)++(atomExprs b)
atomExprs (Iff a b) = unique $ (atomExprs a)++(atomExprs b)
atomExprs (Imp a b) = unique $ (atomExprs a)++(atomExprs b)
atomExprs (Not a)   = unique $ (atomExprs a)
atomExprs (Const a) = []
atomExprs a = [a]

subExprs :: Expr -> [Expr]
subExprs (And a b) = (And a b):(subExprs a)++(subExprs b)
subExprs (Or a b)  = (Or a b):(subExprs a)++(subExprs b)
subExprs (Iff a b) = (Iff a b):(subExprs a)++(subExprs b)
subExprs (Imp a b) = (Imp a b):(subExprs a)++(subExprs b)
subExprs (Not (Const _)) = []
subExprs (Not a)   = (Not a):(subExprs a)
subExprs (Const a) = []
subExprs a = [a]


assignPattern :: Expr -> [[Assign]]
assignPattern expr = pair (atomExprs expr) [True,False]
        where
        pair :: [Expr] -> [Bool] -> [[Assign]]
        pair _ [] = [[]]
        pair [] _ = [[]]
        pair ((Atom a):as) bs = do
                                b <- bs
                                rest <- pair as bs
                                return ((Assign a b):rest)

isTautology :: Expr -> Bool
isTautology expr  = and [evalExpr (assignExpr pat expr) | pat <- assignPattern expr]

動作はこんな感じです。

ghci>  liftM isTautology $ parseExpr "(AvB)"
Right False

evalExprは(Atom _)な形式に遭遇したら"未束縛な変更があるぞ"とかそういうエラーをはかせたいのでTypeはExpr -> Either Error Boolにするべきかとおもっ足りもします。がすると後でevalExprを内部的に利用している関数をすべてliftMする必要があるなとか思って面倒なので、まだやっておりません。

真理値表を出力するためのatomExprsやsubExprsはありますが、表形式に出力するための整形が面倒なのでやっておりません。

=======
追記

evalExpr :: Expr -> Either String Bool
evalExpr (And a b) = liftM2 (&&) (evalExpr a) (evalExpr b)
evalExpr (Or  a b) = liftM2 (||) (evalExpr a) (evalExpr b)
evalExpr (Not a) =   liftM not (evalExpr a)
evalExpr (Imp (Const True) (Const False)) = Right False
evalExpr (Imp a b) = evalExpr =<< (liftM2 Imp (liftM Const (evalExpr a)) (liftM Const (evalExpr b)))
evalExpr (Iff a b) = liftM2 (==) (evalExpr a) (evalExpr b)
evalExpr (Const a) = Right a
evalExpr (Atom _)  = Left "Unassigned atom"

evalExprWith :: Expr -> [Assign] -> Either String Bool
evalExprWith expr assign = evalExpr $ assignExpr assign expr

sTautology :: Expr -> Either String Bool
isTautology expr  = liftM and $ sequence [evalExpr (assignExpr pat expr) | pat <- assignPattern expr]

このようにきちんとエラーを伝播するようにしてみました。
パースエラーが出るとその旨報告されます。（ただ、RightやLeftが二段になるのが気持ち悪いのでそこはどうにかしたいです。）

ghci>  liftM evalExpr $ parseExpr "(avT)"
Right (Left "Unassigned atom")

ghci> liftM isTautology $ parseExpr "(avT)"
Right (Right True)

ghci> liftM isTautology $ parseExpr "(avT"
Left "Parse Error" (line 1, column 1):
unexpected "("
expecting "T", "F", ")" or "~"
ghci>

何かいい方法がありますでしょうか？(joinは中のEitherと外のEitherの型が (Either ParseError Expr)と(Either String Bool)と違うのでjoinは使えない（？）ようです。