> {-# LANGUAGE ViewPatterns #-}

> import Control.Applicative > import Control.Arrow > import Control.Monad > import Data.Function > import List > import Maybe > import Text.Show

> infixr 1 :-> > infixr 2 :\/ > infixr 3 :/\ > infixr 1 --> > infixr 1 <-- > infixr 1 <-> > infixr 2 \/ > infixr 3 /\ > (\/) = (:\/) > (/\) = (:/\) > (-->) = (:->) > (<--) = flip (:->) > p <-> q = (p :-> q) :/\ (q :-> p)

> data Prop = Letter String > | Prop :\/ Prop > | Prop :/\ Prop > | Prop :-> Prop > | Box Prop > | Dia Prop > | F > | T > | Neg Prop deriving (Eq, Ord)

show

> instance Show Prop where > showsPrec p (a :/\ b) = showParen (p>3) $ showsPrec 3 a . showString " /\\ " . showsPrec 3 b > showsPrec p (a :\/ b) = showParen (p>2) $ showsPrec 2 a . showString " \\/ " . showsPrec 2 b > showsPrec p (a :-> b) = showParen (p>1) $ showsPrec 1 a . showString " --> " . showsPrec 1 b > showsPrec p (Neg r) = showParen (p>4) $ showString "Neg " . showsPrec 5 r > showsPrec p (Box r) = showParen (p>4) $ showString "Box " . showsPrec 5 r > showsPrec p (Dia r) = showParen (p>4) $ showString "Dia " . showsPrec 5 r > showsPrec p (Letter n)= showParen (p>5) $ showsPrec 6 n > showsPrec p T = showString "T" > showsPrec p F = showString "F"

> simplify p = let simplify' (a :\/ F) = a > simplify' (F :\/ b) = b > simplify' (a :/\ T) = a > simplify' (T :/\ b) = b > simplify' (a :\/ T) = T > simplify' (T :\/ b) = T > simplify' (a :/\ F) = F > simplify' (F :/\ b) = F > simplify' (F :-> b) = T > simplify' (T :-> b) = b > simplify' (a :-> F) = Neg a > simplify' (a :-> T) = T > simplify' (Neg T) = F > simplify' (Neg F) = T > simplify' (Box T) = T > simplify' (Dia F) = F > simplify' z = z > in case p of > a :/\ b -> let a' = simplify a > b' = simplify b > in simplify' (a' :/\ b') > a :\/ b -> let a' = simplify a > b' = simplify b > in simplify' (a' :\/ b') > a :-> b -> simplify' (simplify a :-> simplify b) > Box a -> simplify' (Box (simplify a)) > Dia a -> simplify' (Dia (simplify a)) > Neg (Neg a) -> simplify a > a -> a

PropType

Atomic

Constant

T

F

DoubleNegation

Disjunction

Conjunction

Provability

Consistency

> data PropType a = Atomic a > | Constant a > | DoubleNegation a > | Disjunction a a > | Conjunction a a > | Provability a > | Consistency a > instance Functor PropType where > fmap f (Atomic a) = Atomic (f a) > fmap f (Constant a) = Constant (f a) > fmap f (DoubleNegation a) = DoubleNegation (f a) > fmap f (Provability a) = Provability (f a) > fmap f (Consistency a) = Consistency (f a) > fmap f (Conjunction a b) = Conjunction (f a) (f b) > fmap f (Disjunction a b) = Disjunction (f a) (f b)

PropType

> class PropTypeable a where > propType :: a -> PropType a > neg :: a -> a > isF :: a -> Bool > negative :: a -> Bool > positiveComponent :: a -> Prop

> instance PropTypeable Prop where > propType (a :\/ b) = Disjunction a b > propType (a :/\ b) = Conjunction a b > propType (Neg (a :\/ b)) = Conjunction (Neg a) (Neg b) > propType (Neg (a :/\ b)) = Disjunction (Neg a) (Neg b) > propType (a :-> b) = Disjunction (Neg a) b > propType (Neg (a :-> b)) = Conjunction a (Neg b) > propType (Neg (Neg a)) = DoubleNegation a > propType (Box a) = Provability a > propType (Neg (Box a)) = Consistency (Neg a) > propType (Dia a) = Consistency a > propType (Neg (Dia a)) = Provability (Neg a) > propType (Letter a) = Atomic (Letter a) > propType (Neg (Letter a)) = Atomic (Neg (Letter a)) > propType T = Constant T > propType F = Constant F > propType (Neg F) = Constant T > propType (Neg T) = Constant F > neg = Neg > isF F = True > isF (Neg T) = True > isF _ = False > positiveComponent (Neg a) = a > positiveComponent a = a > negative (Neg _) = True > negative _ = False

> [a, b, c, d, p, q, r, s, t] = map (Letter . return) "abcdpqrst"

placesWhere

> placesWhere p [] = [] > placesWhere p (x:xs) = let r = map (second (x:)) $ placesWhere p xs > in if p x then ((x, xs) : r) else r

==

> findIntersection eq a b = listToMaybe [(x, y) | x <- a, y <- b, x `eq` y]

propositional

> propositional (propType -> DoubleNegation _) = True > propositional (propType -> Conjunction _ _) = True > propositional (propType -> Disjunction _ _) = True > propositional _ = False

provability

> provability (propType -> Provability _) = True > provability (propType -> Consistency _) = True > provability _ = False

prop

Prop

result

> data TableauRules prop result = TableauRules {

closes

> closes :: result -> Bool,

F

> foundF :: prop -> result,

> foundContradiction :: (prop, prop) -> result,

> open :: [prop] -> result,

conjRule

> conjRule :: prop -> prop -> result -> result,

disjRule rules

> disjRule :: prop -> prop -> prop -> result -> result -> result,

doubleNegation

> doubleNegation :: prop -> result -> result,

Dia

processWorld

combineWorlds

> processWorld :: prop -> result -> result, > combineWorlds :: result -> result -> result,

> tableau :: [prop] -> result -> result > }

> simpleClosure rules ps = case find isF ps of > Just a -> foundF rules a

> Nothing -> > let (neg, pos) = partition negative ps > maybePair = findIntersection ((==) `on` positiveComponent) neg pos > in case maybePair of > Just pair -> foundContradiction rules pair > Nothing -> open rules ps

> applyDNeg rules p a props = doubleNegation rules a $ > applyPropositional rules (a : delete p props)

> applyConj rules p a b props = conjRule rules a b $ > applyPropositional rules (a : b : delete p props)

> applyDisj rules p a b props = > let props' = delete p props > left = applyPropositional rules (a : props') > right = applyPropositional rules (b : props') > in disjRule rules p a b left right

> applyPropositional rules props = > let t = simpleClosure rules props in if closes rules t > then t > else case find propositional props of > Nothing -> applyProvability t rules props > Just p -> case p of > (propType -> DoubleNegation q) -> applyDNeg rules p q props > (propType -> Conjunction a b) -> applyConj rules p a b props > (propType -> Disjunction a b) -> applyDisj rules p a b props

Dia p

Neg (Box p)

> applyProvability t rules props = > let impliedWorlds = placesWhere consistency props > consistency (propType -> Consistency _) = True > consistency _ = False > testWorld (p@(propType -> Consistency q), props) =

neg p

provabilities

> let tableau = runTableau rules (q : neg p : provabilities) > provabilities = do > p@(propType -> Provability q) <- props > [p, q] > in processWorld rules p tableau > in foldr (combineWorlds rules) t (map testWorld impliedWorlds)

> runTableau rules props = tableau rules props $ applyPropositional rules props

Bool

(&&)

> validRules = TableauRules { > closes = id, > open = \_ -> False, > foundF = \_ -> True, > foundContradiction = \_ -> True, > conjRule = \_ _ t -> t, > disjRule = \_ _ _ -> (&&), > doubleNegation = \_ t -> t, > combineWorlds = (||), > processWorld = \_ t -> t, > tableau = \_ t -> t > }

> valid p = runTableau validRules [neg p]

> valids = [ > T, > a :-> a, > Box a :-> Box a, > Box a :-> Box (Box a), > Box (Box a :-> a) :-> Box a, > Box F <-> Box (Dia T), > let x = p :/\ q :-> r :-> a in Box (Box x :-> x) :-> Box x, > F :-> Dia p, > Box (Dia p) :-> Box (Box F :-> F), > (Box F \/ q /\ Dia (Box F /\ Neg q)) <-> > (Dia (Box F \/ q /\ Dia (Box F /\ Neg q)) > --> q /\ Neg (Box (Box F \/ q /\ Dia (Box F /\ Neg q) > --> q))) > ] > invalids = [ > F, > a :-> Box a, > Box a :-> a, > Box (Box a :-> a) :-> a, > Dia T, > Box (Dia T), > Neg (Box F), > (Box F \/ p /\ Dia (Box F /\ Neg q)) <-> > (Dia (Box F \/ q /\ Dia (Box F /\ Neg q)) > --> q /\ Neg (Box (Box F \/ q /\ Dia (Box F /\ Neg q) > --> q))) > ]

regress1

True

> regress1 = do > print $ (and $ map valid valids) && > (and $ map (not . valid) invalids)