197 lines
No EOL
9.1 KiB
Haskell
197 lines
No EOL
9.1 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
module Resolution where
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import FOLSyntax
|
|
( Formula(Exists, Pred, Neg, Conj, Disj, Impl, All),
|
|
Term(..),
|
|
formulaVars,
|
|
termFreeVars,
|
|
termSubst,
|
|
findFresh )
|
|
import Data.Maybe ( mapMaybe )
|
|
import Data.List
|
|
import Control.Monad (zipWithM)
|
|
|
|
type CNF = Set Clause
|
|
type Clause = Set Literal
|
|
type Literal = Formula
|
|
type Unifier = [(Term, Term)]
|
|
|
|
|
|
-- alpha equality on clauses, a clause [S(x), P(y)] is equal to [S(y), P(x)]
|
|
-- 1. get all permutations of both clauses
|
|
-- 2. build the crossproduct of permutations of c1 and c2
|
|
-- 3. unify each clause pair
|
|
-- 4. collect mgus where variables are only mapped to variables (meaning they are alpha eq)
|
|
-- 5. check if any such mgu exists
|
|
alphaEq :: Clause -> Clause -> Bool
|
|
alphaEq c1 c2 = any (uncurry unifyLiteralList) permutationPairs
|
|
where
|
|
permutationPairs = [(c1', c2') | c1' <- permutations $ Set.toList c1, c2' <- permutations $ Set.toList c2]
|
|
|
|
set1 :: Clause
|
|
set1 = Set.fromList [Pred "S" [Var "x"], Pred "P" [Var "y"]]
|
|
set2 :: Clause
|
|
set2 = Set.fromList [Pred "P" [Var "z"], Pred "S" [Var "y"]]
|
|
|
|
-- unification algorithm of martelli montanari
|
|
unify :: [(Term, Term)] -> Maybe Unifier
|
|
unify [] = Just []
|
|
-- (delete)
|
|
unify ((Var x, Var y) : rest) | x == y = unify rest
|
|
-- (decomp)
|
|
unify ((Fun f es, Fun g ds) : rest) | f == g && length es == length ds = unify $ zip es ds ++ rest
|
|
-- (conflict)
|
|
unify ((Fun _ _, Fun _ _) : _) = Nothing
|
|
-- (orient)
|
|
unify ((Fun f ts, Var x) : rest) = unify $ (Var x, Fun f ts) : rest
|
|
-- (occurs)
|
|
unify ((Var x, t) : _) | x `elem` termFreeVars t && Var x /= t = Nothing
|
|
-- (elim)
|
|
unify ((Var x, t) : rest) | notElem x (termFreeVars t) && x `elem` concatMap (\(t1, t2) -> termFreeVars t1 ++ termFreeVars t2) rest = unify $ (Var x, t) : map (\(t1, t2) -> (termSubst t1 x t, termSubst t2 x t)) rest
|
|
-- decent
|
|
unify ((t, s) : rest) = do
|
|
rest' <- unify rest
|
|
return $ (t, s) : rest'
|
|
|
|
unifyLiteralList :: [Literal] -> [Literal] -> Bool
|
|
unifyLiteralList ls1 ls2 = case zipWithM unifyLiterals ls1 ls2 of
|
|
Nothing -> False
|
|
Just mgus -> all checkSimpleMgu mgus
|
|
where
|
|
checkSimpleMgu :: Unifier -> Bool
|
|
checkSimpleMgu [] = True
|
|
checkSimpleMgu ((Var _, Var _) : _) = True
|
|
checkSimpleMgu _ = False
|
|
unifyLiterals :: Literal -> Literal -> Maybe Unifier
|
|
unifyLiterals (Neg f) (Neg g) = unifyLiterals f g
|
|
unifyLiterals (Pred p ts1) (Pred s ts2) | p == s && length ts1 == length ts2 = unify $ zip ts1 ts2
|
|
unifyLiterals _ _ = Nothing
|
|
|
|
-- unifies predicates, e.g. P(x,y) == P(f(a), z)
|
|
unifyPredicates :: Literal -> Literal -> Maybe Unifier
|
|
unifyPredicates (Pred p1 ts1) (Neg (Pred p2 ts2)) | p1 == p2 && length p1 == length p2 = unify $ zip ts1 ts2
|
|
unifyPredicates _ _ = Nothing
|
|
|
|
setConcat :: Ord a => [Set a] -> Set a
|
|
setConcat = foldr Set.union Set.empty
|
|
|
|
-- applies an mgu to a given formula, asserts that the formula contains no quantifiers
|
|
applyMgu :: Formula -> [(Term, Term)] -> Formula
|
|
applyMgu (Pred p ts) mgu = Pred p $ map (`applyMguTerm` mgu) ts
|
|
applyMgu (Neg f) mgu = Neg $ applyMgu f mgu
|
|
applyMgu (Conj f1 f2) mgu = Conj (applyMgu f1 mgu) (applyMgu f2 mgu)
|
|
applyMgu (Disj f1 f2) mgu = Disj (applyMgu f1 mgu) (applyMgu f2 mgu)
|
|
applyMgu (Impl f1 f2) mgu = Impl (applyMgu f1 mgu) (applyMgu f2 mgu)
|
|
applyMgu f _ = f
|
|
-- applies mgu to term
|
|
applyMguTerm :: Term -> [(Term, Term)] -> Term
|
|
applyMguTerm (Var x) [] = Var x
|
|
applyMguTerm (Var x) ((Var y, t) : rest) = if x == y then t else applyMguTerm (Var x) rest
|
|
applyMguTerm (Fun f ts) mgu = Fun f $ map (`applyMguTerm` mgu) ts
|
|
applyMguTerm t _ = t
|
|
|
|
-- takes two clauses and makes the variables of these clauses disjunct
|
|
makeVariablesDisjunct :: Clause -> Clause -> (Clause, Clause)
|
|
makeVariablesDisjunct c1 c2 = (c1', c2')
|
|
where
|
|
(used, c1') = makeClauseDisjunct [] c1
|
|
(_, c2') = makeClauseDisjunct used c2
|
|
-- takes a list of variable names and ensures that the clause does not contain these variables (by renaming), then returns all variables used in the clause + used before
|
|
makeClauseDisjunct :: [String] -> Clause -> ([String], Clause)
|
|
makeClauseDisjunct used clause = (concatMap formulaVars newClause ++ newUsed, newClause)
|
|
where
|
|
criticalVars = used `intersect` concatMap formulaVars clause
|
|
(newUsed, newClause) = foldr foldFun (used, clause) criticalVars
|
|
where
|
|
foldFun oldVar (used', clause') = (v' : used', Set.map (\f -> renameFormula f oldVar v') clause')
|
|
where
|
|
v' = findFresh used'
|
|
|
|
-- renames all occurences of variable v with v' in a term
|
|
renameTerm :: Term -> String -> String -> Term
|
|
renameTerm t@(Var x) v v' = if x == v then Var v' else t
|
|
renameTerm (Fun g ts) v v' = Fun g (map (\t -> renameTerm t v v') ts)
|
|
|
|
-- renames all occurences of free variable v with v' in a formula
|
|
renameFormula :: Formula -> String -> String -> Formula
|
|
renameFormula (Pred p ts) v v' = Pred p (map (\t -> renameTerm t v v') ts)
|
|
renameFormula (Neg f') v v' = Neg $ renameFormula f' v v'
|
|
renameFormula (Conj f1 f2) v v' = Conj (renameFormula f1 v v') (renameFormula f2 v v')
|
|
renameFormula (Disj f1 f2) v v' = Disj (renameFormula f1 v v') (renameFormula f2 v v')
|
|
renameFormula (Impl f1 f2) v v' = Impl (renameFormula f1 v v') (renameFormula f2 v v')
|
|
renameFormula (All y f') v v' | y /= v = All y $ renameFormula f' v v'
|
|
renameFormula (Exists y f') v v' | y /= v = Exists y $ renameFormula f' v v'
|
|
renameFormula f' _ _ = f'
|
|
|
|
-- takes two clauses and tries to unify every literal in a crossproduct, returns the set of all clauses resulting from this resolution step
|
|
resolveClauses :: Clause -> Clause -> Set Clause
|
|
resolveClauses c1 c2 = newClauses
|
|
where
|
|
-- first make variables in both clauses disjunct
|
|
(c1', c2') = makeVariablesDisjunct c1 c2
|
|
zippedLiterals = [(lit1, lit2) | lit1 <- Set.toList c1', lit2 <- Set.toList c2']
|
|
newClauses = Set.fromList $ mapMaybe (\(l1, l2) -> do
|
|
-- first calculate mgu
|
|
mgu <- unifyPredicates l1 l2
|
|
-- now apply mgu to clauses without l1 and l2
|
|
let c1'' = Set.map (`applyMgu` mgu) (c1' `Set.difference` Set.singleton l1)
|
|
let c2'' = Set.map (`applyMgu` mgu) (c2' `Set.difference` Set.singleton l2)
|
|
return $ c1'' `Set.union` c2''
|
|
) zippedLiterals
|
|
|
|
-- a single resolution step as described in gloin
|
|
resolveStep :: CNF -> Either () CNF
|
|
resolveStep clauses = if Set.empty `Set.member` clauses then Left () else Right $ clauses `Set.union` newClauses
|
|
where
|
|
-- cross product of clauses
|
|
zippedClauses = [(c1, c2) | c1 <- Set.toList clauses, c2 <- Set.toList clauses, c1 /= c2]
|
|
-- after resolveStep add every clause that can be gained through resolution to clauseSet
|
|
newClauses = setConcat $ map (uncurry resolveClauses) zippedClauses
|
|
|
|
resolveStepVerbose :: Set ([Clause], Clause) -> Either (Set ([Clause], Clause)) (Set ([Clause], Clause))
|
|
resolveStepVerbose clauses = if Set.empty `inRight` clauses then Left clauses else Right $ clauses `Set.union` newClauses
|
|
where
|
|
inRight clause set = clause `Set.member` Set.map snd set
|
|
-- cross product of clauses
|
|
zippedClauses = [(c1, c2) | c1 <- Set.toList (Set.map snd clauses), c2 <- Set.toList (Set.map snd clauses), c1 /= c2]
|
|
-- after resolveStep add every clause that can be gained through resolution to clauseSet
|
|
newClauses = setConcat' $ map (\(c1, c2) -> ([c1, c2], resolveClauses c1 c2)) zippedClauses
|
|
|
|
setConcat' :: [([Clause], Set Clause)] -> Set ([Clause], Clause)
|
|
setConcat' [] = Set.empty
|
|
setConcat' ((cs, clauses) : rest) = Set.map (cs,) clauses `Set.union` setConcat' rest
|
|
|
|
-- do resolution until we have proven unfulfillability of formula set
|
|
doResolution :: CNF -> Either () CNF
|
|
doResolution f = do
|
|
f' <- resolveStep f
|
|
doResolution f'
|
|
|
|
doResolutionIO :: CNF -> IO (Either () (Set ([Clause], Clause)))
|
|
doResolutionIO cnf = do
|
|
let preparedCNF = Set.map ([], ) cnf
|
|
resolutionHelper preparedCNF 1
|
|
where
|
|
resolutionHelper :: Set ([Clause], Clause) -> Int -> IO (Either () (Set ([Clause], Clause)))
|
|
resolutionHelper set n = do
|
|
let setE = resolveStepVerbose set
|
|
case setE of
|
|
Left _ -> do
|
|
putStrLn "Resolved to empty clause, so formula is proven!"
|
|
return $ Left ()
|
|
Right set' -> do
|
|
putStrLn $ "Resolution iteration " ++ show n ++ ":\n"
|
|
printResolvents (Set.toList $ set' `Set.difference` set)
|
|
putStrLn ""
|
|
resolutionHelper set' (n + 1)
|
|
|
|
printResolvents :: [([Clause], Clause)] -> IO ()
|
|
printResolvents (([c1, c2], c) : rest) = do
|
|
putStrLn $ "Resolving " ++ showClause c1 ++ " and " ++ showClause c2 ++ "\n-> " ++ showClause c
|
|
printResolvents rest
|
|
printResolvents _ = return ()
|
|
|
|
showClause :: Clause -> String
|
|
showClause c = "[" ++ intercalate ", " (map show (Set.toList c)) ++ "]" |