module Tableau where import Formula import Subst import Term import Control.Monad.State import Data.List((\\)) import Blocks import Print import Parser -- Discrimination now has two more possibilities data Discrim v a = Alpha a a | Beta a a | Lit a | Gamma v a | Delta v a deriving Show notP (Conn Not [x]) = x notP x = Conn Not [x] -- discrim is like before, but now over (Formula p f v) rather then (Prop a) discrim :: Formula p f v -> Discrim v (Formula p f v) discrim (p@(Rel r ts)) = Lit p discrim (Conn T []) = Lit (Conn T []) discrim (Conn F []) = Lit (Conn F []) discrim (Conn And [x,y]) = Alpha x y discrim (Conn Or [x,y]) = Beta x y discrim (Conn Imp [x,y]) = Beta (notP x) y discrim (Conn Not [x]) = case x of (Rel r ts) -> Lit(notP x) (Conn T []) -> Lit(Conn F []) (Conn F []) -> Lit(Conn T []) (Conn And [x,y]) -> Beta (notP x) (notP y) (Conn Or [x,y]) -> Alpha (notP x) (notP y) (Conn Imp [x,y]) -> Alpha x (notP y) (Conn Not [x]) -> discrim x (Quant All v f) -> Delta v (notP f) (Quant Exist v f) -> Gamma v (notP f) discrim (Quant All v f) = Gamma v f discrim (Quant Exist v f) = Delta v f ----------------------------------------------------- -- unification over terms occurs :: Eq v => v -> Term f v -> Maybe () occurs v t = hasV (variables t) where hasV [] = Just () hasV (Var u : xs) | v==u = Nothing hasV (x:xs) = hasV xs unify :: (Eq f, Eq v) => Term f v -> Term f v -> Maybe (Subst v (Term f)) unify (Var v) (Var u) | u==v = return emptySubst unify (Var v) y = do { occurs v y ; return(v |-> y)} unify y (Var v) = do { occurs v y ; return (v |-> y) } unify (Fun _ f ts) (Fun _ g ss) | f==g = unifyLists ts ss unify x y = Nothing unifyLists :: (Eq f, Eq v) => [Term f v] -> [Term f v] -> Maybe (Subst v (Term f)) unifyLists [] [] = Just emptySubst unifyLists [] (x:xs) = Nothing unifyLists (x:xs) [] = Nothing unifyLists (x:xs) (y:ys) = do { s1 <- unify x y ; s2 <- unifyLists (map (subTerm s1) xs) (map (subTerm s1) ys) ; return(s2 |=> s1)} unifyForm (Rel x ts) (Rel y ss) | x==y = unifyLists ts ss unifyForm (Conn c1 ts) (Conn c2 ss) | c1==c2 = unifyForms ts ss unifyForm x y = Nothing unifyForms [] [] = Just emptySubst unifyForms [] (x:xs) = Nothing unifyForms (x:xs) [] = Nothing unifyForms (x:xs) (y:ys) = do { s1 <- unifyForm x y ; s2 <- unifyForms (map (subst s1) xs) (map (subst s1) ys) ; return(s2 |=> s1)} conjugates x y = case unifyForm x (notP y) of Just s -> Just(s,subst s x,subst s y) Nothing -> case unifyForm (notP x) y of Just s -> Just(s,subst s x,subst s y) Nothing -> Nothing someConj x [] = Nothing someConj x (y:ys) = case conjugates x y of Just triple -> Just triple Nothing -> someConj x ys --------------------------------------------- -- type FormulaS = Formula String String String data Tree = Direct (FormulaS) Tree | Branch Tree Tree | Leaf | Closed FormulaS FormulaS 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) extendTree p (Closed x y) = Closed x y -- make 1 and 2 elements trees single p = Direct (p) Leaf double p q = Direct (p) (single q) extendTruths (True,p) truths = p:truths extendTruths (False,p) truths = (notP p):truths -- invariant: elements of the list are in -- the tree but not yet "used" tabTree :: [FormulaS] -> Tree -> State Int Tree tabTree [] tree = return 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 -> do x <- tabTree (a:xs) (single a) y <- tabTree (b:xs) (single b) return(extendTree (Branch x y) tree) Gamma s f -> do { t <- freshTerm ; let form = (subst (s |-> t) f) ; tabTree (form:xs) (extendTree (single form) tree) } Delta s f -> do { t <- freshSkolem s f ; tabTree (t:xs) (extendTree (single t) tree)} freshInt :: State Int Int freshInt = do { n <- get; put (n+1); return n} freshTerm = do { n <- freshInt; return (Var ("n"++show n))} freshSkolem :: String -> FormulaS -> State Int FormulaS freshSkolem v form = do { n <- freshInt ; let us = vars form \\ [Var v] term = Fun True ("f"++show n) us ; return(subst (v |-> term) form)} try x = tblock tree where (tree,next) = runState (tabTree [notP x] (single (notP x))) 1 f1 = toFormula "(forall x. O(x,x)) --> (forall x. exists y. O(x,y))" f2 = toFormula "(forall x. O(x,x)) --> (forall x. forall y. O(x,x) | O(y,y))" f3 = toFormula "(forall x. O(x,x)) --> (forall x. forall y. O(x,x) & O(y,y))" ------------------------------------------------ -- code for printing and drawing trees instance Show Tree where show Leaf = "" show (Branch x y) = "["++show x ++ "/\\"++ show y++"]" show (Direct (p) t) = "{"++show p++" "++show t++"}" show (Closed x y) = "X("++show x++","++show y++")" lblock (p) = beside True (oneBlock "")(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) tblock (Closed x y) = oneBlock(show(Closed x y)) --------------------------------------------------- -- 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. -- We only keep literals in the path. isLit (p@(Rel r ts)) = True isLit (Conn T []) = True isLit (Conn F []) = True isLit (Conn Not [t]) = isLit t 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:: [FormulaS] -> [[FormulaS]] -> State Int [[FormulaS]] tab3 [] paths = return 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 -> do { ms <- tab3 (insert3 a xs) (map (cons3 a) paths) ; ns <- tab3 (insert3 b xs) (map (cons3 b) paths) ; return (ms++ns)} Gamma v f -> do { t <- freshTerm ; let form = (subst (v |-> t) f) ; tab3 (form:xs) paths } Delta s f -> do { t <- freshSkolem s f ; tab3 (t:xs) paths } try2 x = runState (tab3 [notP x] [[]]) 1

AltStyle によって変換されたページ (->オリジナル) /