module Tableau2 where
import SimpleProp
import Blocks
import qualified Test.QuickCheck as QC
import Test.QuickCheck hiding (Prop)
import Control.Monad(liftM,liftM2)
data Tree n
= Direct (Bool,Prop n) (Tree n)
| Branch (Tree n) (Tree n)
| Leaf
------------------------------------------------
-- code for printing and drawing trees
instance PPLetter n => Show (Tree n) where
show Leaf = ""
show (Branch x y) = "["++show x ++ "/\\"++ show y++"]"
show (Direct (True,p) t) = "{T "++show p++" "++show t++"}"
show (Direct (False,p) t) = "{F "++show p++" "++show t++"}"
lblock (True,p) = beside True (oneBlock "T ")(oneBlock (show p))
lblock (False,p) = beside True (oneBlock "F ")(oneBlock (show p))
tblock Leaf = oneBlock ""
tblock (Direct x t) = above (center (lblock x) w) bottom
where bottom = (tblock t)
w = width bottom
tblock (Branch x y) = (sep True 2 bs)
where bs = map (box 0 . tblock) [x,y]
w = sum (map width bs)
-----------------------------------------------------
-- the two examples in the Smullyan text
item = (0 + (1 * 2)) ~> ((0 + 1)*(0+2))
tree :: Tree Int
tree = mk2 False item
blk = tblock tree
item2 = (p ~> (q ~> r)) ~> ((p ~> q) ~> (p ~> r))
where p = LetterP "p"; q = LetterP "q"; r = LetterP "r"
tree2 :: Tree String
tree2 = mk2 False item2
blk2 = tblock tree2
bad = (0 + (1 * 2)) ~> ((0 + 2)*(1+2))
-- This code mimics the by hand construction of
-- Signed tableau, by direct inspection the Sign
-- and structure of the term. This is somewhat AdHoc
mk2 :: Bool -> Prop n -> Tree n
mk2 b (NotP x) = Direct (b,NotP x) (mk2 (not b) x)
mk2 True (AndP x y) = Direct (True,AndP x y) (push (mk2 True y) (mk2 True x))
mk2 False (AndP x y) = Direct (False,AndP x y) (Branch (mk2 False x) (mk2 False y))
mk2 True (OrP x y) = Direct (True,OrP x y) (Branch (mk2 True x) (mk2 True y))
mk2 False (OrP x y) = Direct (False,OrP x y) (push (mk2 False y) (mk2 False x))
mk2 True (ImpliesP x y) = Direct (True,ImpliesP x y) (Branch (mk2 False x) (mk2 True y))
mk2 False (ImpliesP x y) =
Direct (False,ImpliesP x y) (push (mk2 False y) (mk2 True x))
mk2 bool prop = Direct (bool,prop) Leaf
push:: Tree n -> Tree n -> Tree n
push Leaf t = t
push t Leaf = t
push (Direct s m) (Direct t n) = Direct t (Direct s (push m n))
push t (Direct pair m) = Direct pair (push t m)
push (Direct s m) (Branch x y) = Direct s (Branch (push m x) (push m y))
push t (Branch x y) = Branch (push t x) (push t y)
----------------------------------------------
-- Is a tree closed? I.e. it is not satisfiable
extendTruths (True,p) truths = p:truths
extendTruths (False,p) truths = (NotP p):truths
closed:: Eq n => Tree n -> [Prop n] -> Bool
closed Leaf truths = False
closed (Direct (pair@(True,p)) tree) truths =
elem (NotP p) truths || closed tree (extendTruths pair truths)
closed (Direct (pair@(False,p)) tree) truths =
elem p truths || closed tree (extendTruths pair truths)
closed (Branch x y) truths =
closed x truths && closed y truths
----------------------------------------------------
-- Now build a tree using Alpha and Beta rules
-- This we we have far fewer cases. This is the
-- same function we used for implementing CNF
data Discrim a = Alpha a a | Beta a a | Lit a
deriving Show
discrim :: Prop a -> Discrim (Prop a)
discrim TruthP = Lit TruthP
discrim AbsurdP = Lit AbsurdP
discrim (LetterP s) = Lit (LetterP s)
discrim (AndP x y) = Alpha x y
discrim (OrP x y) = Beta x y
discrim (ImpliesP x y) = Beta (NotP x) y
discrim (NotP (OrP x y)) = Alpha (NotP x) (NotP y)
discrim (NotP (ImpliesP x y)) = Alpha x (NotP y)
discrim (NotP (AndP x y)) = Beta (NotP x) (NotP y)
discrim (NotP (NotP x)) = discrim x
discrim (NotP TruthP) = Lit AbsurdP
discrim (NotP AbsurdP) = Lit TruthP
discrim (NotP (LetterP s)) = Lit (NotP (LetterP s))
---------------------------------------------------
-- Build a tableau according to page 24 of Smullyan
-- make 1 and 2 elements trees
single p = Direct (True,p) Leaf
double p q = Direct (True,p) (single q)
-- invariant: elements of the list are in
-- the tree but not yet "used"
tabTree [] tree = tree
tabTree (x:xs) tree =
case discrim x of
Lit p -> tabTree xs tree
Alpha a b -> tabTree (a:b:xs) (extendTree (double a b) tree)
Beta a b -> extendTree
(Branch (tabTree (a:xs) (single a))
(tabTree (b:xs) (single b)))
tree
extendTree p Leaf = p
extendTree p (Direct q t) = Direct q (extendTree p t)
extendTree p (Branch x y) = Branch (extendTree p x) (extendTree p y)
solveT p = tblock (tabTree [NotP p] (single (NotP p)))
----------------------------------------------------------------
-- An optimization is to keep the elements in the "not used"
-- list ordered in a way that keeps Alpha terms first.
-- This makes the tree deep, rather than wide.
-- Try and choose Alpha rules before Beta Rules
cmp x y =
case (discrim x,discrim y) of
(Alpha _ _, _) -> GT
(Lit _, _) -> GT
(Beta _ _,_) -> LT
insert x [] = [x]
insert x (y:ys) =
case cmp x y of
GT -> x : y : ys
other -> y : insert x ys
tabTree2 [] tree = tree
tabTree2 (x:xs) tree =
case discrim x of
Lit p -> tabTree2 xs tree
Alpha a b -> tabTree2 (insert a (insert b xs)) (extendTree (double a b) tree)
Beta a b -> extendTree
(Branch (tabTree2 (insert a xs) (single a))
(tabTree2 (insert b xs) (single b)))
tree
solveT2 p = tblock (tabTree2 [NotP p] (single (NotP p)))
---------------------------------------------------
-- Now we will try a use the Tableau method without
-- actually constructing the Tree. Instead we will
-- construct a list of paths in the tree.
-- The simplest version, no attempt at optimization
tab1 [] paths = paths
tab1 (x:xs) paths =
case discrim x of
Lit p -> tab1 xs (map (p:) paths)
Alpha a b -> tab1 (a : b : xs) (map (\ path -> a:b:path) paths)
-- Beta a b -> tab1 (a : b: xs) [ p:ps | p <- [a,b],ps <- paths]
-- I first thought the above would work but it adds extra bogus paths
Beta a b -> tab1 (a:xs) (map (a:) paths) ++
tab1 (b:xs) (map (b:) paths)
solve1 p = tab1 [NotP p] [[]]
----------------------------------------------------------------
-- Use the optimization of using Alpha nodes first.
-- reuse the "insert" function from "tabTree2" above.
tab2 [] paths = paths
tab2 (x:xs) paths =
case discrim x of
Lit p -> tab2 xs (map (p:) paths)
Alpha a b -> tab2 (insert a (insert b xs)) (map (\ path -> a:b:path) paths)
Beta a b -> tab2 (insert a xs) (map (a:) paths) ++
tab2 (insert b xs) (map (b:) paths)
solve2 p = tab2 [NotP p] [[]]
----------------------------------------------------
-- Simplify paths, Keep only literals, and keep
-- only one copy
isLit (LetterP x) = True
isLit (NotP (LetterP x)) = True
isLit TruthP = True
isLit AbsurdP = True
isLit x = False
cons3 x xs | not (isLit x) = xs
cons3 x xs | elem x xs = xs
cons3 x xs = x : xs
insert3 x xs = x :xs
tab3 [] paths = paths
tab3 (x:xs) paths =
case discrim x of
Lit p -> tab3 xs (map (cons3 p) paths)
Alpha a b -> tab3 (insert3 a (insert3 b xs)) (map (cons3 a . cons3 b) paths)
Beta a b -> tab3 (insert3 a xs) (map (cons3 a) paths) ++
tab3 (insert3 b xs) (map (cons3 b) paths)
solve3 p = tab3 [NotP p] [[]]
----------------------------------------------------
-- Keep two lists of paths, active, and closed
-- a closed path has a contradiction.
conjugatePair [] = False
conjugatePair [x] = False
conjugatePair (LetterP x : xs) = elem (NotP (LetterP x)) xs
conjugatePair (NotP x : xs) = elem x xs
conjugatePair (x:xs) = conjugatePair xs
split ([],closed) = ([],closed)
split (x:xs,closed) | conjugatePair x = split (xs,x:closed)
split (x:xs,closed) = (x:ys,zs) where (ys,zs) = split (xs,closed)
tab4 :: Eq n => [Prop n] -> ([[Prop n]],[[Prop n]]) -> ([[Prop n]],[[Prop n]])
tab4 [] (paths,closed) = (paths,closed)
tab4 (x:xs) (paths,closed) =
case discrim x of
Lit p -> tab4 xs (split(map (cons3 p) paths,closed))
Alpha a b -> tab4 (insert3 a (insert3 b xs))
(split(map (cons3 a . cons3 b) paths,closed))
Beta a b ->
merge (tab4 (insert3 a xs) (split (map (cons3 a) paths,[])))
(tab4 (insert3 b xs) (split (map (cons3 b) paths,[])))
closed
merge (xs,ys) (ws,zs) closed = (xs++ws,ys++zs++closed)
solve4 p = tab4 [NotP p] ([[]],[])
----------------------------------------------------
-- Combine the two-lists and putting Alpha terms
-- earlier in the work list. Note that we may cutoff
-- all paths before we have used the Beta terms that
-- do unnecessary splitting
tab5 [] (paths,closed) = (paths,closed)
tab5 (x:xs) (paths,closed) =
case discrim x of
Lit p -> tab5 xs (split(map (cons3 p) paths,closed))
Alpha a b -> tab5 (insert a (insert b xs))
(split(map (cons3 a . cons3 b) paths,closed))
Beta a b ->
merge (tab4 (insert a xs) (split (map (cons3 a) paths,[])))
(tab4 (insert b xs) (split (map (cons3 b) paths,[])))
closed
solve5 p = tab5 [NotP p] ([[]],[])
--------------------------------------------------
-- How do we prove a property P about Trees?
-- An induction proof would have three parts.
-- 1) Show P(Leaf)
-- 2) Assume P(x), then show P(Direct (t,p) x)
-- 3) Assume P(x) and P(y), then show P(Branch x y)
-- How do we prove a property P about (Prop n)?
-- An induction proof would have 7 parts
-- 1) Show P(TruthP)
-- 2) Show P (AbsurdP)
-- 3) Show P (LetterP x)
-- 4) Assume P(x) and then show P(NotP x)
-- 5) Assume P(x) and P(y) and then show P(AndP x y)
-- 6) Assume P(x) and P(y) and then show P(OrP x y)
-- 7) Assume P(x) and P(y) and then show P(ImpliesP x y)
-- How do we prove a property about Discrim?
-- Three cases
-- 1) Show P(Let x)
-- 2) Show P(Alpha x y)
-- 3) Show P(Beta x y)
alpha1 (Alpha x y) = x
alpha2 (Alpha x y) = y
beta1 (Beta x y) = x
beta2 (Beta x y) = y
conjugate (NotP x) = x
conjugate x = NotP x
-----------------------------------------------
-- Rules of discrimnation
prop1 :: Prop Int -> Property
prop1 p = taut p ==>
(case discrim p of
Lit x -> taut x
Alpha x y -> taut x && taut y
Beta x y -> taut x || taut y)
prop1a f p = taut p ==>
(case discrim p of
Lit x -> val f x
Alpha x y -> val f x && val f y
Beta x y -> val f x || val f y)
alpha x =
case discrim x of
(Alpha _ _) -> True
(Beta _ _) -> False
(Lit _) -> False
beta x =
case discrim x of
(Alpha _ _) -> False
(Beta _ _) -> True
(Lit _) -> False
prop2,prop3:: Prop Int -> Property
prop2 x = alpha x ==> beta(conjugate x)
prop3 x = beta x ==> alpha(conjugate x)
prop4 zs x = alpha x ==>
val zs (alpha1 (discrim x)) &&
val zs (alpha2 (discrim x)) ==>
val zs x
-- Not every set is downward and upward closed!!
-- these are definitions not properties
downwardClosed set =
and [ case discrim x of
Alpha a b -> elem a set && elem b set
Beta a b -> elem a set || elem b set
Lit _ -> True
| x <- set ]
upwardClosed set =
and [ case (discrim x, discrim y) of
(Alpha _ _, Alpha _ _) -> elem (AndP x y) set
(Beta _ _,Beta _ _) -> elem (OrP x y) set
other -> True
| x <- set, y <- set ]
---------------------------------------------------
instance Arbitrary a => Arbitrary (Prop a) where
-- coarbitrary = undefined
arbitrary = oneof [return AbsurdP, return TruthP
, liftM LetterP arbitrary
, liftM NotP arbitrary
, liftM2 AndP arbitrary arbitrary
, liftM2 OrP arbitrary arbitrary
]
addvars:: Ord a => Prop a -> [a] -> [a]
addvars TruthP ans = ans
addvars AbsurdP ans = ans
addvars (LetterP x) ans = insertX x ans
addvars (NotP x) ans = addvars x ans
addvars (AndP x y) ans = addvars x (addvars y ans)
addvars (OrP x y) ans = addvars x (addvars y ans)
addvars (ImpliesP x y) ans = addvars x (addvars y ans)
insertX x [] = [x]
insertX x (y:ys) | x==y = y:ys
| xy = y:(insertX x ys)
vars:: Ord a => Prop a -> [a]
vars x = addvars x []
assigns:: [Int] -> [[(Int,Bool)]]
assigns [] = []
assigns [n] = [[(n,True)],[(n,False)]]
assigns (x:xs) = map ((x,True):) ys ++ map ((x,False):) ys
where ys = assigns xs
taut:: Prop Int -> Bool
taut prop = and [ value (lift x) prop | x <- assigns (vars prop)]
where lift pairs x = case lookup x pairs of
Just b -> b
other -> False
val xs prop = value (lift xs) prop
where lift pairs x = case lookup x pairs of
Just b -> b
other -> False