Haskell之命题与重载

import Data.List

-- 定义命题的类型
data Prop = Const Bool
 | Var Char
 | Not Prop
 | And Prop Prop
 | Or Prop Prop
 | Imply Prop Prop
   deriving Eq

-- 定义p1、p2、p3三种命题
p1 = And (Var 'A') (Not (Var 'A'))
p2 = Or (Var 'A') (Not (Var 'A'))
p3 = Imply (Var 'A') (And (Var 'A') (Var 'B'))

-- 重载Show类以显示命题
instance Show Prop where
show (Const True) = "True"
show (Const False) = "False"
show (Var x) = [x]
show (Not x) = "~"++show x
show (And x y) = (show x) ++ "&&" ++(show y)
show (Or x y) = (show x) ++ "||" ++ (show y)
show (Imply x y) = (show x) ++ "=>" ++ (show y) 

type Subst = [(Char,Bool)]

eval :: Subst->Prop->Bool
eval sub (Const p)= p           -- 常量真值判断
eval sub (Var p)=(getBool sub p) -- 单命题判断
eval sub (Not p)= not (eval sub p) -- 非命题判断
eval sub (And p q)= (eval sub p) && (eval sub q)-- 与命题判断
eval sub (Or p q)= (eval sub p)||(eval sub q) -- 或命题判断
eval sub (Imply p q)= ((eval sub p)&&(eval sub q))||(not (eval sub p)) -- 蕴含命题判断：p=>q的真值表等价于p&&q || (~p)

-- 找到变元的真值
getBool :: Subst->Char->Bool
getBool sub x = if length xs >1 then
  error "Too much value for variable"
else
  head xs
                where
    xs = [k|(y,k)<-sub,x==y]

-- 提取命题中的变元，并剔除重复部分
vars :: Prop -> [Char]
vars (Const x) = []
vars (Var x) = [x]
vars (Not p) = vars p
vars (And p q) = nub((vars p)++(vars q))
vars (Or p q) = nub((vars p)++(vars q))
vars (Imply p q) = nub((vars p)++(vars q))

-- 由变元组成的所有真值的组合
substs :: Prop->[Subst]
substs p = getsub (vars p)

-- 得到由变元组成的所有真值的组合
getsub :: [Char]->[Subst]
getsub [] = []
getsub [x] = [[(x,True)]]++[[(x,False)]]
getsub (x:xs) = [(x,True):a|a<-getsub(xs)]++[(x,False):a|a<-getsub(xs)]

-- 判断一个命题是否为永真式
isTaut :: Prop->Bool
isTaut p = testisTaut p (substs p)

-- 辅助判断一个命题是否为永真式
testisTaut :: Prop->[Subst]->Bool
testisTaut p [x] = (eval x p)
testisTaut p (x:xs) = if (eval x p) then 
 testisTaut p xs
     else
  False