diff --git a/Data/Boolean.hs b/Data/Boolean.hs --- a/Data/Boolean.hs +++ b/Data/Boolean.hs @@ -1,37 +1,47 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS -fno-warn-incomplete-patterns #-} -- | -- Module : Data.Boolean -- Copyright : Sebastian Fischer -- License : BSD3 --- +-- -- Maintainer : Sebastian Fischer (sebf@informatik.uni-kiel.de) -- Stability : experimental -- Portability : portable --- +-- -- This library provides a representation of boolean formulas that is -- used by the solver in "Data.Boolean.SatSolver". --- +-- -- We also define a function to simplify formulas, a type for -- conjunctive normalforms, and a function that creates them from -- boolean formulas. --- -module Data.Boolean ( +-- +module Data.Boolean ( - Boolean(..), + Boolean(..), - Literal(..), literalVar, invLiteral, isPositiveLiteral, + Literal(..), literalVar, invLiteral, isPositiveLiteral, CNF, Clause, booleanToCNF ) where -import Data.Maybe ( mapMaybe ) -import qualified Data.IntMap as IM - import Control.Monad ( guard, liftM ) +import Data.Generics (Data, Typeable) +import qualified Data.IntMap as IM +import Data.Logic.ATP.Formulas (IsAtom, IsFormula(..)) +import Data.Logic.ATP.Lit (IsLiteral(..)) +import Data.Logic.ATP.Prop (IsPropositional(..), JustPropositional) +import Data.Logic.ATP.Pretty (HasFixity(..), Pretty(pPrint), text) +import Data.Maybe ( mapMaybe ) -- | Boolean formulas are represented as values of type @Boolean@. --- +-- data Boolean -- | Variables are labeled with an @Int@, = Var Int @@ -48,37 +58,77 @@ deriving Show -- | Literals are variables that occur either positively or negatively. --- +-- data Literal = Pos Int | Neg Int deriving (Eq, Show) +instance Ord Literal where + compare (Neg _) (Pos _) = LT + compare (Pos _) (Neg _) = GT + compare (Pos m) (Pos n) = compare m n + compare (Neg m) (Neg n) = compare m n + +deriving instance Data Literal +deriving instance Typeable Literal + -- | This function returns the name of the variable in a literal. --- +-- literalVar :: Literal -> Int literalVar (Pos n) = n literalVar (Neg n) = n -- | This function negates a literal. --- +-- invLiteral :: Literal -> Literal invLiteral (Pos n) = Neg n invLiteral (Neg n) = Pos n -- | This predicate checks whether the given literal is positive. --- +-- isPositiveLiteral :: Literal -> Bool isPositiveLiteral (Pos _) = True isPositiveLiteral _ = False -- | Conjunctive normalforms are lists of lists of literals. --- +-- type CNF = [Clause] type Clause = [Literal] --- | +instance JustPropositional CNF + +instance HasFixity Int + +instance IsAtom Int + +instance IsFormula CNF where + type AtomOf CNF = Int + atomic = error "FIXME: IsFormula CNF MyAtom" + overatoms = error "FIXME: IsFormula CNF MyAtom" + onatoms = error "FIXME: IsFormula CNF MyAtom" + asBool = error "FIXME: HasBoolean CNF" + true = error "FIXME: HasBoolean CNF" + false = error "FIXME: HasBoolean CNF" +instance Pretty Literal where + pPrint = text . show +instance IsPropositional CNF where + foldPropositional' = error "FIXME: IsPropositional CNF MyAtom" + foldCombination = error "FIXME: IsCombinable CNF" + _ .|. _ = error "FIXME: IsCombinable CNF" + _ .&. _ = error "FIXME: IsCombinable CNF" + _ .=>. _ = error "FIXME: IsCombinable CNF" + _ .<=>. _ = error "FIXME: IsCombinable CNF" +instance HasFixity CNF where + precedence _ = error "FIXME: HasFixity CNF" + associativity _ = error "FIXME: HasFixity CNF" +instance IsLiteral CNF where + foldLiteral' = error "FIXME: IsLiteral CNF MyAtom" + naiveNegate = error "FIXME: IsNegatable CNF" + foldNegation = error "FIXME: IsNegatable CNF" + +-- | -- We convert boolean formulas to conjunctive normal form by pushing -- negations down to variables and repeatedly applying the -- distributive laws. --- +-- booleanToCNF :: Boolean -> CNF booleanToCNF = mapMaybe (simpleClause . map literal . disjunction) @@ -92,7 +142,7 @@ elim (No :&&: _) = Just No elim (Yes :&&: x) = Just x elim (_ :&&: No) = Just No - elim (x :&&: Yes) = Just x + elim (x :&&: Yes) = Just x elim (Yes :||: _) = Just Yes elim (No :||: x) = Just x elim (_ :||: Yes) = Just Yes diff --git a/Data/Boolean/SatSolver.hs b/Data/Boolean/SatSolver.hs --- a/Data/Boolean/SatSolver.hs +++ b/Data/Boolean/SatSolver.hs @@ -2,50 +2,61 @@ -- Module : Data.Boolean.SatSolver -- Copyright : Sebastian Fischer -- License : BSD3 --- +-- -- Maintainer : Sebastian Fischer (sebf@informatik.uni-kiel.de) -- Stability : experimental -- Portability : portable --- +-- -- This Haskell library provides an implementation of the -- Davis-Putnam-Logemann-Loveland algorithm -- (cf. ) for the boolean -- satisfiability problem. It not only allows to solve boolean -- formulas in one go but also to add constraints and query bindings -- of variables incrementally. --- +-- -- The implementation is not sophisticated at all but uses the basic -- DPLL algorithm with unit propagation. --- -module Data.Boolean.SatSolver ( - - Boolean(..), SatSolver, Literal(..), literalVar, invLiteral, isPositiveLiteral, CNF, Clause, booleanToCNF, - - newSatSolver, isSolved, - - lookupVar, assertTrue, assertTrue', branchOnVar, selectBranchVar, solve, isSolvable +-- - ) where +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} -import Data.List -import Data.Boolean +module Data.Boolean.SatSolver + ( SatSolver + , newSatSolver + , isSolved + , lookupVar + , assertTrue + , assertTrue' + , branchOnVar + , selectBranchVar + , solve + , isSolvable + ) where import Control.Monad.Writer - +import Data.Boolean (Boolean, booleanToCNF, Clause, CNF, invLiteral, isPositiveLiteral, Literal(Pos, Neg), literalVar) import qualified Data.IntMap as IM +import Data.List +--import Formulas (HasBoolean(..), IsCombinable(..), IsFormula(..), IsNegatable(..)) +--import Lit (IsLiteral(..)) +--import Pretty (HasFixity) +--import Prop (IsPropositional(..)) -- | A @SatSolver@ can be used to solve boolean formulas. --- -data SatSolver = SatSolver { clauses :: CNF, bindings :: IM.IntMap Bool } - deriving Show +-- +data SatSolver + = SatSolver + { clauses :: CNF + , bindings :: IM.IntMap Bool + } deriving Show -- | A new SAT solver without stored constraints. --- +-- newSatSolver :: SatSolver newSatSolver = SatSolver [] IM.empty -- | This predicate tells whether all constraints are solved. --- +-- isSolved :: SatSolver -> Bool isSolved = null . clauses @@ -53,14 +64,14 @@ -- We can lookup the binding of a variable according to the currently -- stored constraints. If the variable is unbound, the result is -- @Nothing@. --- +-- lookupVar :: Int -> SatSolver -> Maybe Bool lookupVar name = IM.lookup name . bindings --- | +-- | -- We can assert boolean formulas to update a @SatSolver@. The -- assertion may fail if the resulting constraints are unsatisfiable. --- +-- assertTrue :: MonadPlus m => Boolean -> SatSolver -> m SatSolver assertTrue formula solver = do newClauses <- foldl (addClause (bindings solver)) @@ -79,7 +90,7 @@ -- This function guesses a value for the given variable, if it is -- currently unbound. As this is a non-deterministic operation, the -- resulting solvers are returned in an instance of @MonadPlus@. --- +-- branchOnVar :: MonadPlus m => Int -> SatSolver -> m SatSolver branchOnVar name solver = maybe (branchOnUnbound name solver) @@ -93,11 +104,11 @@ selectBranchVar :: SatSolver -> Int selectBranchVar = literalVar . head . head . sortBy shorter . clauses --- | +-- | -- This function guesses values for variables such that the stored -- constraints are satisfied. The result may be non-deterministic and -- is, hence, returned in an instance of @MonadPlus@. --- +-- solve :: MonadPlus m => SatSolver -> m SatSolver solve solver | isSolved solver = return solver @@ -108,7 +119,7 @@ -- solvable. Use with care! This might be an inefficient operation. It -- tries to find a solution using backtracking and returns @True@ if -- and only if that fails. --- +-- isSolvable :: SatSolver -> Bool isSolvable = not . (null :: [a] -> Bool) . solve diff --git a/Data/Logic.hs b/Data/Logic.hs new file mode 100644 --- /dev/null +++ b/Data/Logic.hs @@ -0,0 +1,17 @@ +module Data.Logic + ( module Data.Logic.ATP.Prop + , module Data.Logic.Classes.Atom + , module Data.Logic.Normal.Implicative + , module Data.Logic.Instances.Test + , module Data.Set + , module Data.String + , module Text.PrettyPrint.HughesPJClass + ) where + +import Data.Logic.ATP.Prop hiding (Atom, T, F, Not, And, Or, Imp, Iff, nnf) +import Data.Logic.Classes.Atom +import Data.Logic.Normal.Implicative +import Data.Logic.Instances.Test hiding (Formula, V, Predicate, Formula, SkTerm, Skolem, SkAtom, Var, Fn) +import Data.Set +import Data.String +import Text.PrettyPrint.HughesPJClass (pPrint, prettyShow) diff --git a/Data/Logic/Classes/Apply.hs b/Data/Logic/Classes/Apply.hs deleted file mode 100644 --- a/Data/Logic/Classes/Apply.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, - RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} -{-# OPTIONS -fno-warn-missing-signatures #-} --- | The Apply class represents a type of atom the only supports predicate application. -module Data.Logic.Classes.Apply - ( Apply(..) - , Predicate - , apply - , zipApplys - , apply0, apply1, apply2, apply3, apply4, apply5, apply6, apply7 - , showApply - , prettyApply - , varApply - , substApply - , pApp, pApp0, pApp1, pApp2, pApp3, pApp4, pApp5, pApp6, pApp7 - ) where - -import Data.Data (Data) -import Data.Logic.Classes.Arity -import Data.Logic.Classes.Constants -import Data.Logic.Classes.Formula (Formula(atomic)) -import Data.Logic.Classes.Pretty (Pretty) -import Data.Logic.Classes.Term (Term, showTerm, prettyTerm, fvt, tsubst) -import Data.List (intercalate, intersperse) -import Data.Maybe (fromMaybe) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Text.PrettyPrint (Doc, (<>), text, empty, parens, cat) - -class (Arity p, Constants p, Eq p, Ord p, Data p, Pretty p) => Predicate p - -class Predicate p => Apply atom p term | atom -> p term where - foldApply :: (p -> [term] -> r) -> (Bool -> r) -> atom -> r - apply' :: p -> [term] -> atom - --- | apply' with an arity check - clients should always call this. -apply :: Apply atom p term => p -> [term] -> atom -apply p ts = - case arity p of - Just n | n /= length ts -> error "arity" - _ -> apply' p ts - -zipApplys :: Apply atom p term => - (p -> [term] -> p -> [term] -> Maybe r) - -> (Bool -> Bool -> Maybe r) - -> atom -> atom -> Maybe r -zipApplys ap tf a1 a2 = - foldApply ap' tf' a1 - where - ap' p1 ts1 = foldApply (ap p1 ts1) (\ _ -> Nothing) a2 - tf' x1 = foldApply (\ _ _ -> Nothing) (tf x1) a2 - -apply0 p = if fromMaybe 0 (arity p) == 0 then apply' p [] else error "arity" -apply1 p a = if fromMaybe 1 (arity p) == 1 then apply' p [a] else error "arity" -apply2 p a b = if fromMaybe 2 (arity p) == 2 then apply' p [a,b] else error "arity" -apply3 p a b c = if fromMaybe 3 (arity p) == 3 then apply' p [a,b,c] else error "arity" -apply4 p a b c d = if fromMaybe 4 (arity p) == 4 then apply' p [a,b,c,d] else error "arity" -apply5 p a b c d e = if fromMaybe 5 (arity p) == 5 then apply' p [a,b,c,d,e] else error "arity" -apply6 p a b c d e f = if fromMaybe 6 (arity p) == 6 then apply' p [a,b,c,d,e,f] else error "arity" -apply7 p a b c d e f g = if fromMaybe 7 (arity p) == 7 then apply' p [a,b,c,d,e,f,g] else error "arity" - -showApply :: (Apply atom p term, Term term v f, Show v, Show p, Show f) => atom -> String -showApply = - foldApply (\ p ts -> "(pApp" ++ show (length ts) ++ " (" ++ show p ++ ") (" ++ intercalate ") (" (map showTerm ts) ++ "))") - (\ x -> if x then "true" else "false") - -prettyApply :: (Apply atom p term, Term term v f) => (v -> Doc) -> (p -> Doc) -> (f -> Doc) -> Int -> atom -> Doc -prettyApply pv pp pf _prec atom = - foldApply (\ p ts -> - pp p <> case ts of - [] -> empty - _ -> parens (cat (intersperse (text ",") (map (prettyTerm pv pf) ts)))) - (\ x -> text (if x then "true" else "false")) - atom - --- | Return the variables that occur in an instance of Apply. -varApply :: (Apply atom p term, Term term v f) => atom -> Set.Set v -varApply = foldApply (\ _ args -> Set.unions (map fvt args)) (const Set.empty) - -substApply :: (Apply atom p term, Constants atom, Term term v f) => Map.Map v term -> atom -> atom -substApply env = foldApply (\ p args -> apply p (map (tsubst env) args)) fromBool - -{- -instance (Apply atom p term, Term term v f, Constants atom) => Formula atom term v where - allVariables = varApply - freeVariables = varApply - substitute = substApply --} - -pApp :: forall formula atom term p. (Formula formula atom, Apply atom p term) => p -> [term] -> formula -pApp p ts = atomic (apply p ts :: atom) - --- | Versions of pApp specialized for different argument counts. -pApp0 :: forall formula atom term p. (Formula formula atom, Apply atom p term) => p -> formula -pApp0 p = atomic (apply0 p :: atom) -pApp1 :: forall formula atom term p. (Formula formula atom, Apply atom p term) => p -> term -> formula -pApp1 p a = atomic (apply1 p a :: atom) -pApp2 :: forall formula atom term p. (Formula formula atom, Apply atom p term) => p -> term -> term -> formula -pApp2 p a b = atomic (apply2 p a b :: atom) -pApp3 :: forall formula atom term p. (Formula formula atom, Apply atom p term) => p -> term -> term -> term -> formula -pApp3 p a b c = atomic (apply3 p a b c :: atom) -pApp4 :: forall formula atom term p. (Formula formula atom, Apply atom p term) => p -> term -> term -> term -> term -> formula -pApp4 p a b c d = atomic (apply4 p a b c d :: atom) -pApp5 :: forall formula atom term p. (Formula formula atom, Apply atom p term) => p -> term -> term -> term -> term -> term -> formula -pApp5 p a b c d e = atomic (apply5 p a b c d e :: atom) -pApp6 :: forall formula atom term p. (Formula formula atom, Apply atom p term) => p -> term -> term -> term -> term -> term -> term -> formula -pApp6 p a b c d e f = atomic (apply6 p a b c d e f :: atom) -pApp7 :: forall formula atom term p. (Formula formula atom, Apply atom p term) => p -> term -> term -> term -> term -> term -> term -> term -> formula -pApp7 p a b c d e f g = atomic (apply7 p a b c d e f g :: atom) diff --git a/Data/Logic/Classes/Arity.hs b/Data/Logic/Classes/Arity.hs deleted file mode 100644 --- a/Data/Logic/Classes/Arity.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Data.Logic.Classes.Arity - ( Arity(arity) - ) where - --- |A class that characterizes how many arguments a predicate or --- function takes. Depending on the context, a result of Nothing may --- mean that the arity is undetermined or unknown. However, even if --- this returns Nothing, the same number of arguments must be passed --- to all uses of a given predicate or function. -class Arity p where - arity :: p -> Maybe Int diff --git a/Data/Logic/Classes/ClauseNormalForm.hs b/Data/Logic/Classes/ClauseNormalForm.hs --- a/Data/Logic/Classes/ClauseNormalForm.hs +++ b/Data/Logic/Classes/ClauseNormalForm.hs @@ -4,12 +4,12 @@ ) where import Control.Monad (MonadPlus) -import Data.Logic.Classes.Negate +import Data.Logic.ATP.Lit import Data.Set as S -- |A class to represent formulas in CNF, which is the conjunction of -- a set of disjuncted literals each which may or may not be negated. -class (Negatable lit, Eq lit, Ord lit) => ClauseNormalFormula cnf lit | cnf -> lit where +class (IsLiteral lit, Eq lit, Ord lit) => ClauseNormalFormula cnf lit | cnf -> lit where clauses :: cnf -> S.Set (S.Set lit) makeCNF :: S.Set (S.Set lit) -> cnf satisfiable :: MonadPlus m => cnf -> m Bool diff --git a/Data/Logic/Classes/Combine.hs b/Data/Logic/Classes/Combine.hs deleted file mode 100644 --- a/Data/Logic/Classes/Combine.hs +++ /dev/null @@ -1,123 +0,0 @@ --- | Class Logic defines the basic boolean logic operations, --- AND, OR, NOT, and so on. Definitions which pertain to both --- propositional and first order logic are here. -{-# LANGUAGE DeriveDataTypeable #-} -module Data.Logic.Classes.Combine - ( Combinable(..) - , Combination(..) - , combine - , BinOp(..) - , binop - -- * Unicode aliases for Combinable class methods - , (∧) - , (∨) - , (⇒) - , (⇔) - -- * Use in Harrison's code - , (==>) - , (<=>) - , prettyBinOp - ) where - -import Data.Generics (Data, Typeable) -import Data.Logic.Classes.Negate (Negatable, (.~.)) -import Data.Logic.Classes.Pretty (Pretty(pretty)) -import Text.PrettyPrint (Doc, text) - --- | A type class for logical formulas. Minimal implementation: --- @ --- (.|.) --- @ -class (Negatable formula) => Combinable formula where - -- | Disjunction/OR - (.|.) :: formula -> formula -> formula - - -- | Derived formula combinators. These could (and should!) be - -- overridden with expressions native to the instance. - -- - -- | Conjunction/AND - (.&.) :: formula -> formula -> formula - x .&. y = (.~.) ((.~.) x .|. (.~.) y) - -- | Formula combinators: Equivalence - (.<=>.) :: formula -> formula -> formula - x .<=>. y = (x .=>. y) .&. (y .=>. x) - -- | Implication - (.=>.) :: formula -> formula -> formula - x .=>. y = ((.~.) x .|. y) - -- | Reverse implication: - (.<=.) :: formula -> formula -> formula - x .<=. y = y .=>. x - -- | Exclusive or - (.<~>.) :: formula -> formula -> formula - x .<~>. y = ((.~.) x .&. y) .|. (x .&. (.~.) y) - -- | Nor - (.~|.) :: formula -> formula -> formula - x .~|. y = (.~.) (x .|. y) - -- | Nand - (.~&.) :: formula -> formula -> formula - x .~&. y = (.~.) (x .&. y) - -infixl 1 .<=>. , .<~>., ⇔, <=> -infixr 2 .=>., ⇒, ==> -infixr 3 .|., ∨ -infixl 4 .&., ∧ - --- |'Combination' is a helper type used in the signatures of the --- 'foldPropositional' and 'foldFirstOrder' methods so can represent --- all the ways that formulas can be combined using boolean logic - --- negation, logical And, and so forth. -data Combination formula - = BinOp formula BinOp formula - | (:~:) formula - deriving (Eq, Ord, Data, Typeable, Show, Read) - --- | A helper function for building folds: --- @ --- foldPropositional combine atomic --- @ --- is a no-op. -combine :: Combinable formula => Combination formula -> formula -combine (BinOp f1 (:<=>:) f2) = f1 .<=>. f2 -combine (BinOp f1 (:=>:) f2) = f1 .=>. f2 -combine (BinOp f1 (:&:) f2) = f1 .&. f2 -combine (BinOp f1 (:|:) f2) = f1 .|. f2 -combine ((:~:) f) = (.~.) f - --- | Represents the boolean logic binary operations, used in the --- Combination type above. -data BinOp - = (:<=>:) -- ^ Equivalence - | (:=>:) -- ^ Implication - | (:&:) -- ^ AND - | (:|:) -- ^ OR - deriving (Eq, Ord, Data, Typeable, Enum, Bounded, Show, Read) - -binop :: Combinable formula => formula -> BinOp -> formula -> formula -binop a (:&:) b = a .&. b -binop a (:|:) b = a .|. b -binop a (:=>:) b = a .=>. b -binop a (:<=>:) b = a .<=>. b - -(∧) :: Combinable formula => formula -> formula -> formula -(∧) = (.&.) -(∨) :: Combinable formula => formula -> formula -> formula -(∨) = (.|.) --- | ⇒ can't be a function when -XUnicodeSyntax is enabled. -(⇒) :: Combinable formula => formula -> formula -> formula -(⇒) = (.=>.) -(⇔) :: Combinable formula => formula -> formula -> formula -(⇔) = (.<=>.) - -(==>) :: Combinable formula => formula -> formula -> formula -(==>) = (.=>.) -(<=>) :: Combinable formula => formula -> formula -> formula -(<=>) = (.<=>.) - -prettyBinOp :: BinOp -> Doc -prettyBinOp (:<=>:) = text "⇔" -prettyBinOp (:=>:) = text "⇒" -prettyBinOp (:&:) = text "∧" -prettyBinOp (:|:) = text "∨" - -instance Pretty BinOp where - pretty = prettyBinOp diff --git a/Data/Logic/Classes/Constants.hs b/Data/Logic/Classes/Constants.hs deleted file mode 100644 --- a/Data/Logic/Classes/Constants.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Data.Logic.Classes.Constants - ( Constants(asBool, fromBool) - , ifElse - , true - , (⊨) - , false - , (⊭) - , prettyBool - ) where - -import Data.Logic.Classes.Pretty (Pretty(pretty)) -import Text.PrettyPrint (Doc, text) - --- |Some types in the Logic class heirarchy need to have True and --- False elements. -class Constants p where - asBool :: p -> Maybe Bool - fromBool :: Bool -> p - -true :: Constants p => p -true = fromBool True - -false :: Constants p => p -false = fromBool False - -ifElse :: a -> a -> Bool -> a -ifElse t _ True = t -ifElse _ f False = f - -(⊨) :: Constants formula => formula -(⊨) = true -(⊭) :: Constants formula => formula -(⊭) = false - -prettyBool :: Bool -> Doc -prettyBool True = text "⊨" -prettyBool False = text "⊭" - -instance Pretty Bool where - pretty = prettyBool diff --git a/Data/Logic/Classes/Equals.hs b/Data/Logic/Classes/Equals.hs deleted file mode 100644 --- a/Data/Logic/Classes/Equals.hs +++ /dev/null @@ -1,203 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} --- | Support for equality. -module Data.Logic.Classes.Equals - ( AtomEq(..) - , applyEq - , PredicateName(..) - , zipAtomsEq - , apply0, apply1, apply2, apply3, apply4, apply5, apply6, apply7 - , pApp, pApp0, pApp1, pApp2, pApp3, pApp4, pApp5, pApp6, pApp7 - , showFirstOrderFormulaEq - , (.=.), (≡) - , (.!=.), (≢) - , fromAtomEq - , showAtomEq - , prettyAtomEq - , varAtomEq - , substAtomEq - , funcsAtomEq - ) where - -import Data.List (intercalate, intersperse) -import Data.Logic.Classes.Apply (Predicate) -import Data.Logic.Classes.Arity (Arity(..)) -import Data.Logic.Classes.Combine (Combination(..), BinOp(..)) -import Data.Logic.Classes.Constants (Constants(fromBool), ifElse) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), Quant(..)) -import Data.Logic.Classes.Formula (Formula(atomic)) -import Data.Logic.Classes.Negate ((.~.)) -import Data.Logic.Classes.Pretty (Pretty(pretty)) -import Data.Logic.Classes.Term (Term, convertTerm, showTerm, prettyTerm, fvt, tsubst, funcs) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import qualified Data.Set as Set -import Text.PrettyPrint (Doc, (<>), (<+>), text, empty, parens, hcat, nest) - --- | Its not safe to make Atom a superclass of AtomEq, because the Atom methods will fail on AtomEq instances. -class Predicate p => AtomEq atom p term | atom -> term, atom -> p where - foldAtomEq :: (p -> [term] -> r) -> (Bool -> r) -> (term -> term -> r) -> atom -> r - equals :: term -> term -> atom - applyEq' :: p -> [term] -> atom - --- | applyEq' with an arity check - clients should always call this. -applyEq :: AtomEq atom p term => p -> [term] -> atom -applyEq p ts = - case arity p of - Just n | n /= length ts -> arityError p ts - _ -> applyEq' p ts - --- | A way to represent any predicate's name. Frequently the equality --- predicate has no standalone representation in the p type, it is --- just a constructor in the atom type, or even the formula type. -data PredicateName p = Named p Int | Equals deriving (Eq, Ord, Show) - -instance (Pretty p, Ord p) => Pretty (PredicateName p) where - pretty Equals = text "=" - pretty (Named p _) = pretty p - -zipAtomsEq :: AtomEq atom p term => - (p -> [term] -> p -> [term] -> Maybe r) - -> (Bool -> Bool -> Maybe r) - -> (term -> term -> term -> term -> Maybe r) - -> atom -> atom -> Maybe r -zipAtomsEq ap tf eq a1 a2 = - foldAtomEq ap' tf' eq' a1 - where - ap' p1 ts1 = foldAtomEq (ap p1 ts1) (\ _ -> Nothing) (\ _ _ -> Nothing) a2 - tf' x1 = foldAtomEq (\ _ _ -> Nothing) (tf x1) (\ _ _ -> Nothing) a2 - eq' t1 t2 = foldAtomEq (\ _ _ -> Nothing) (\ _ -> Nothing) (eq t1 t2) a2 - -apply0 :: AtomEq atom p term => p -> atom -apply0 p = if fromMaybe 0 (arity p) == 0 then applyEq' p [] else arityError p [] -apply1 :: AtomEq atom p a => p -> a -> atom -apply1 p a = if fromMaybe 1 (arity p) == 1 then applyEq' p [a] else arityError p [a] -apply2 :: AtomEq atom p a => p -> a -> a -> atom -apply2 p a b = if fromMaybe 2 (arity p) == 2 then applyEq' p [a,b] else arityError p [a,b] -apply3 :: AtomEq atom p a => p -> a -> a -> a -> atom -apply3 p a b c = if fromMaybe 3 (arity p) == 3 then applyEq' p [a,b,c] else arityError p [a,b,c] -apply4 :: AtomEq atom p a => p -> a -> a -> a -> a -> atom -apply4 p a b c d = if fromMaybe 4 (arity p) == 4 then applyEq' p [a,b,c,d] else arityError p [a,b,c,d] -apply5 :: AtomEq atom p a => p -> a -> a -> a -> a -> a -> atom -apply5 p a b c d e = if fromMaybe 5 (arity p) == 5 then applyEq' p [a,b,c,d,e] else arityError p [a,b,c,d,e] -apply6 :: AtomEq atom p a => p -> a -> a -> a -> a -> a -> a -> atom -apply6 p a b c d e f = if fromMaybe 6 (arity p) == 6 then applyEq' p [a,b,c,d,e,f] else arityError p [a,b,c,d,e,f] -apply7 :: AtomEq atom p a => p -> a -> a -> a -> a -> a -> a -> a -> atom -apply7 p a b c d e f g = if fromMaybe 7 (arity p) == 7 then applyEq' p [a,b,c,d,e,f,g] else arityError p [a,b,c,d,e,f,g] - -arityError :: (Arity p) => p -> [a] -> t -arityError _p _ts = error "arity error" --- arityError :: (Arity p, Pretty p) => p -> [a] -> t --- arityError p ts = error $ "arity error: " ++ show (length ts) ++ " arguments applied to arity " ++ show (arity p) ++ " predicate " ++ show (pretty p) - -pApp :: (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> [term] -> formula -pApp p ts = atomic (applyEq p ts) - --- | Versions of pApp specialized for different argument counts. -pApp0 :: forall formula atom term v p. (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> formula -pApp0 p = atomic (apply0 p :: atom) -pApp1 :: (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> term -> formula -pApp1 p a = atomic (apply1 p a) -pApp2 :: (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> term -> term -> formula -pApp2 p a b = atomic (apply2 p a b) -pApp3 :: (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> term -> term -> term -> formula -pApp3 p a b c = atomic (apply3 p a b c) -pApp4 :: (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> term -> term -> term -> term -> formula -pApp4 p a b c d = atomic (apply4 p a b c d) -pApp5 :: (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> term -> term -> term -> term -> term -> formula -pApp5 p a b c d e = atomic (apply5 p a b c d e) -pApp6 :: (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> term -> term -> term -> term -> term -> term -> formula -pApp6 p a b c d e f = atomic (apply6 p a b c d e f) -pApp7 :: (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> term -> term -> term -> term -> term -> term -> term -> formula -pApp7 p a b c d e f g = atomic (apply7 p a b c d e f g) - -showFirstOrderFormulaEq :: forall fof atom v p term. (FirstOrderFormula fof atom v, AtomEq atom p term, Show term, Show v, Show p) => fof -> String -showFirstOrderFormulaEq fm = - fst (sfo fm) - where - sfo p = foldFirstOrder qu co tf pr p - qu op v f = (showQuant op ++ " " ++ show v ++ " " ++ parens quantPrec (sfo f), quantPrec) - co ((:~:) p) = - let prec' = 5 in - ("(.~.)" ++ parens prec' (sfo p), prec') - co (BinOp p op q) = (parens (opPrec op) (sfo p) ++ " " ++ showBinOp op ++ " " ++ parens (opPrec op) (sfo q), opPrec op) - tf x = (if x then "true" else "false", 0) - pr = foldAtomEq (\ p ts -> ("pApp " ++ show p ++ " " ++ show ts, 6)) - (\ x -> (if x then "true" else "false", 0)) - (\ t1 t2 -> ("(" ++ show t1 ++ ") .=. (" ++ show t2 ++ ")", 6)) - showBinOp (:<=>:) = ".<=>." - showBinOp (:=>:) = ".=>." - showBinOp (:&:) = ".&." - showBinOp (:|:) = ".|." - showQuant Exists = "exists" - showQuant Forall = "for_all" - opPrec (:|:) = 3 - opPrec (:&:) = 4 - opPrec (:=>:) = 2 - opPrec (:<=>:) = 2 - quantPrec = 1 - parens :: Int -> (String, Int) -> String - parens prec' (s, prec) = if prec >= prec' then "(" ++ s ++ ")" else s - -infix 5 .=., .!=., ≡, ≢ - -(.=.) :: (FirstOrderFormula fof atom v, AtomEq atom p term) => term -> term -> fof -a .=. b = atomic (equals a b) - -(.!=.) :: (FirstOrderFormula fof atom v, AtomEq atom p term) => term -> term -> fof -a .!=. b = (.~.) (a .=. b) - -(≡) :: (FirstOrderFormula fof atom v, AtomEq atom p term) => term -> term -> fof -(≡) = (.=.) - -(≢) :: (FirstOrderFormula fof atom v, AtomEq atom p term) => term -> term -> fof -(≢) = (.!=.) - -{- -instance (AtomEq atom p term, Constants atom, Variable v, Term term v f) => Formula atom term v where - substitute env = foldAtomEq (\ p args -> applyEq p (map (tsubst env) args)) fromBool (\ t1 t2 -> equals (tsubst env t1) (tsubst env t2)) - allVariables = foldAtomEq (\ _ args -> Set.unions (map fvt args)) (const Set.empty) (\ t1 t2 -> Set.union (fvt t1) (fvt t2)) - freeVariables = allVariables --} - -fromAtomEq :: (AtomEq atom1 p1 term1, Term term1 v1 f1, - AtomEq atom2 p2 term2, Term term2 v2 f2, Constants atom2) => - (v1 -> v2) -> (p1 -> p2) -> (f1 -> f2) -> atom1 -> atom2 -fromAtomEq cv cp cf atom = - foldAtomEq (\ pr ts -> applyEq (cp pr) (map ct ts)) - fromBool - (\ a b -> ct a `equals` ct b) - atom - where - ct = convertTerm cv cf - -showAtomEq :: forall atom term v p f. (AtomEq atom p term, Term term v f, Show v, Show p, Show f) => atom -> String -showAtomEq = - foldAtomEq (\ p ts -> "(pApp" ++ show (length ts) ++ " (" ++ show p ++ ") (" ++ intercalate ") (" (map showTerm ts) ++ "))") - (\ x -> if x then "true" else "false") - (\ t1 t2 -> "(" ++ parenTerm t1 ++ " .=. " ++ parenTerm t2 ++ ")") - where - parenTerm :: term -> String - parenTerm x = "(" ++ showTerm x ++ ")" - -prettyAtomEq :: (AtomEq atom p term, Term term v f) => (v -> Doc) -> (p -> Doc) -> (f -> Doc) -> Int -> atom -> Doc -prettyAtomEq pv pp pf prec atom = - foldAtomEq (\ p ts -> pp p <> case ts of - [] -> empty - _ -> parens (hcat (intersperse (text ",") (map (prettyTerm pv pf) ts)))) - (text . ifElse "true" "false") - (\ t1 t2 -> parensIf (prec > 6) (prettyTerm pv pf t1 <+> text "=" <+> prettyTerm pv pf t2)) - atom - where - parensIf False = id - parensIf _ = parens . nest 1 - --- | Return the variables that occur in an instance of AtomEq. -varAtomEq :: forall atom term v p f. (AtomEq atom p term, Term term v f) => atom -> Set.Set v -varAtomEq = foldAtomEq (\ _ args -> Set.unions (map fvt args)) (const Set.empty) (\ t1 t2 -> Set.union (fvt t1) (fvt t2)) - -substAtomEq :: (AtomEq atom p term, Constants atom, Term term v f) => - Map.Map v term -> atom -> atom -substAtomEq env = foldAtomEq (\ p args -> applyEq p (map (tsubst env) args)) fromBool (\ t1 t2 -> equals (tsubst env t1) (tsubst env t2)) - -funcsAtomEq :: (AtomEq atom p term, Term term v f, Ord f) => atom -> Set.Set (f, Int) -funcsAtomEq = foldAtomEq (\ _ ts -> Set.unions (map funcs ts)) (const Set.empty) (\ t1 t2 -> Set.union (funcs t1) (funcs t2)) diff --git a/Data/Logic/Classes/FirstOrder.hs b/Data/Logic/Classes/FirstOrder.hs deleted file mode 100644 --- a/Data/Logic/Classes/FirstOrder.hs +++ /dev/null @@ -1,294 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, - MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TemplateHaskell, UndecidableInstances #-} -module Data.Logic.Classes.FirstOrder - ( FirstOrderFormula(..) - , Quant(..) - , zipFirstOrder - , for_all' - , exists' - , quant - , (!) - , (?) - , (∀) - , (∃) - , quant' - , convertFOF - , toPropositional - , withUnivQuants - , showFirstOrder - , prettyFirstOrder - , fixityFirstOrder - , foldAtomsFirstOrder - , mapAtomsFirstOrder - , onatoms - , overatoms - , atom_union - , fromFirstOrder - , fromLiteral - ) where - -import Data.Generics (Data, Typeable) -import Data.Logic.Classes.Constants -import Data.Logic.Classes.Combine -import Data.Logic.Classes.Formula (Formula(atomic)) -import Data.Logic.Classes.Literal (Literal, foldLiteral) -import Data.Logic.Classes.Negate ((.~.)) -import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), Fixity(..), FixityDirection(..)) -import qualified Data.Logic.Classes.Propositional as P -import Data.Logic.Classes.Variable (Variable) -import Data.Logic.Failing (Failing(..)) -import Data.SafeCopy (base, deriveSafeCopy) -import qualified Data.Set as Set -import Text.PrettyPrint (Doc, (<>), (<+>), text, parens, nest) - --- |The 'FirstOrderFormula' type class. Minimal implementation: --- @for_all, exists, foldFirstOrder, foldTerm, (.=.), pApp0-pApp7, fApp, var@. The --- functional dependencies are necessary here so we can write --- functions that don't fix all of the type parameters. For example, --- without them the univquant_free_vars function gives the error @No --- instance for (FirstOrderFormula Formula atom V)@ because the --- function doesn't mention the Term type. -class ( Formula formula atom - , Combinable formula -- Basic logic operations - , Constants formula - , Constants atom - , HasFixity atom - , Variable v - , Pretty atom, Pretty v - ) => FirstOrderFormula formula atom v | formula -> atom v where - -- | Universal quantification - for all x (formula x) - for_all :: v -> formula -> formula - -- | Existential quantification - there exists x such that (formula x) - exists :: v -> formula -> formula - - -- | A fold function similar to the one in 'PropositionalFormula' - -- but extended to cover both the existing formula types and the - -- ones introduced here. @foldFirstOrder (.~.) quant binOp infixPred pApp@ - -- is a no op. The argument order is taken from Logic-TPTP. - foldFirstOrder :: (Quant -> v -> formula -> r) - -> (Combination formula -> r) - -> (Bool -> r) - -> (atom -> r) - -> formula - -> r - -zipFirstOrder :: FirstOrderFormula formula atom v => - (Quant -> v -> formula -> Quant -> v -> formula -> Maybe r) - -> (Combination formula -> Combination formula -> Maybe r) - -> (Bool -> Bool -> Maybe r) - -> (atom -> atom -> Maybe r) - -> formula -> formula -> Maybe r -zipFirstOrder qu co tf at fm1 fm2 = - foldFirstOrder qu' co' tf' at' fm1 - where - qu' op1 v1 p1 = foldFirstOrder (qu op1 v1 p1) (\ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) fm2 - co' c1 = foldFirstOrder (\ _ _ _ -> Nothing) (co c1) (\ _ -> Nothing) (\ _ -> Nothing) fm2 - tf' x1 = foldFirstOrder (\ _ _ _ -> Nothing) (\ _ -> Nothing) (tf x1) (\ _ -> Nothing) fm2 - at' atom1 = foldFirstOrder (\ _ _ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) (at atom1) fm2 - --- |The 'Quant' and 'InfixPred' types, like the BinOp type in --- 'Data.Logic.Propositional', could be additional parameters to the type --- class, but it would add additional complexity with unclear --- benefits. -data Quant = Forall | Exists deriving (Eq,Ord,Show,Read,Data,Typeable,Enum,Bounded) - --- |for_all with a list of variables, for backwards compatibility. -for_all' :: FirstOrderFormula formula atom v => [v] -> formula -> formula -for_all' vs f = foldr for_all f vs - --- |exists with a list of variables, for backwards compatibility. -exists' :: FirstOrderFormula formula atom v => [v] -> formula -> formula -exists' vs f = foldr for_all f vs - --- |Names for for_all and exists inspired by the conventions of the --- TPTP project. -(!) :: FirstOrderFormula formula atom v => v -> formula -> formula -(!) = for_all -(?) :: FirstOrderFormula formula atom v => v -> formula -> formula -(?) = exists - --- Irrelevant, because these are always used as prefix operators, never as infix. -infixr 9 !, ?, ∀, ∃ - --- | ∀ can't be a function when -XUnicodeSyntax is enabled. -(∀) :: FirstOrderFormula formula atom v => v -> formula -> formula -(∀) = for_all -(∃) :: FirstOrderFormula formula atom v => v -> formula -> formula -(∃) = exists - --- | Helper function for building folds. -quant :: FirstOrderFormula formula atom v => - Quant -> v -> formula -> formula -quant Forall v f = for_all v f -quant Exists v f = exists v f - --- |Legacy version of quant from when we supported lists of quantified --- variables. It also has the virtue of eliding quantifications with --- empty variable lists (by calling for_all' and exists'.) -quant' :: FirstOrderFormula formula atom v => - Quant -> [v] -> formula -> formula -quant' Forall = for_all' -quant' Exists = exists' - -convertFOF :: (FirstOrderFormula formula1 atom1 v1, FirstOrderFormula formula2 atom2 v2) => - (atom1 -> atom2) -> (v1 -> v2) -> formula1 -> formula2 -convertFOF convertA convertV formula = - foldFirstOrder qu co tf (atomic . convertA) formula - where - convert' = convertFOF convertA convertV - qu x v f = quant x (convertV v) (convert' f) - co (BinOp f1 op f2) = combine (BinOp (convert' f1) op (convert' f2)) - co ((:~:) f) = combine ((:~:) (convert' f)) - tf = fromBool - --- |Try to convert a first order logic formula to propositional. This --- will return Nothing if there are any quantifiers, or if it runs --- into an atom that it is unable to convert. -toPropositional :: forall formula1 atom v formula2 atom2. - (FirstOrderFormula formula1 atom v, - P.PropositionalFormula formula2 atom2) => - (atom -> atom2) -> formula1 -> formula2 -toPropositional convertAtom formula = - foldFirstOrder qu co tf at formula - where - convert' = toPropositional convertAtom - qu _ _ _ = error "toPropositional: invalid argument" - co (BinOp f1 op f2) = combine (BinOp (convert' f1) op (convert' f2)) - co ((:~:) f) = combine ((:~:) (convert' f)) - tf = fromBool - at = atomic . convertAtom - --- | Display a formula in a format that can be read into the interpreter. -showFirstOrder :: forall formula atom v. (FirstOrderFormula formula atom v, Show v) => (atom -> String) -> formula -> String -showFirstOrder sa formula = - foldFirstOrder qu co tf at formula - where - qu Forall v f = "(for_all " ++ show v ++ " " ++ showFirstOrder sa f ++ ")" - qu Exists v f = "(exists " ++ show v ++ " " ++ showFirstOrder sa f ++ ")" - co (BinOp f1 op f2) = "(" ++ parenForm f1 ++ " " ++ showCombine op ++ " " ++ parenForm f2 ++ ")" - co ((:~:) f) = "((.~.) " ++ showFirstOrder sa f ++ ")" - tf x = if x then "true" else "false" - at :: atom -> String - at = sa - parenForm x = "(" ++ showFirstOrder sa x ++ ")" - showCombine (:<=>:) = ".<=>." - showCombine (:=>:) = ".=>." - showCombine (:&:) = ".&." - showCombine (:|:) = ".|." - -prettyFirstOrder :: forall formula atom v. (FirstOrderFormula formula atom v) => - (Int -> atom -> Doc) -> (v -> Doc) -> Int -> formula -> Doc -prettyFirstOrder pa pv pprec formula = - parensIf (pprec > prec) $ - foldFirstOrder - (\ qop v f -> prettyQuant qop <> pv v <> text "." <+> (prettyFirstOrder pa pv prec f)) - (\ cm -> - case cm of - (BinOp f1 op f2) -> - case op of - (:=>:) -> (prettyFirstOrder pa pv 2 f1 <+> pretty op <+> prettyFirstOrder pa pv prec f2) - (:<=>:) -> (prettyFirstOrder pa pv 2 f1 <+> pretty op <+> prettyFirstOrder pa pv prec f2) - (:&:) -> (prettyFirstOrder pa pv 3 f1 <+> pretty op <+> prettyFirstOrder pa pv prec f2) - (:|:) -> (prettyFirstOrder pa pv 4 f1 <+> pretty op <+> prettyFirstOrder pa pv prec f2) - ((:~:) f) -> text "¬" {-"~"-} <> prettyFirstOrder pa pv prec f) - (text . ifElse "true" "false") - (pa prec) - formula - where - Fixity prec _ = fixityFirstOrder formula - parensIf False = id - parensIf _ = parens . nest 1 - prettyQuant Forall = text "∀" -- "!" - prettyQuant Exists = text "∃" -- "?" - -fixityFirstOrder :: (HasFixity atom, FirstOrderFormula formula atom v) => formula -> Fixity -fixityFirstOrder formula = - foldFirstOrder qu co tf at formula - where - qu _ _ _ = Fixity 10 InfixN - co ((:~:) _) = Fixity 5 InfixN - co (BinOp _ (:&:) _) = Fixity 4 InfixL - co (BinOp _ (:|:) _) = Fixity 3 InfixL - co (BinOp _ (:=>:) _) = Fixity 2 InfixR - co (BinOp _ (:<=>:) _) = Fixity 1 InfixL - tf _ = Fixity 10 InfixN - at = fixity - --- | Examine the formula to find the list of outermost universally --- quantified variables, and call a function with that list and the --- formula after the quantifiers are removed. -withUnivQuants :: FirstOrderFormula formula atom v => ([v] -> formula -> r) -> formula -> r -withUnivQuants fn formula = - doFormula [] formula - where - doFormula vs f = - foldFirstOrder - (doQuant vs) - (\ _ -> fn (reverse vs) f) - (\ _ -> fn (reverse vs) f) - (\ _ -> fn (reverse vs) f) - f - doQuant vs Forall v f = doFormula (v : vs) f - doQuant vs Exists v f = fn (reverse vs) (exists v f) - --- ------------------------------------------------------------------------- --- Apply a function to the atoms, otherwise keeping structure. --- ------------------------------------------------------------------------- - -mapAtomsFirstOrder :: forall formula atom v. FirstOrderFormula formula atom v => (atom -> formula) -> formula -> formula -mapAtomsFirstOrder f fm = - foldFirstOrder qu co tf at fm - where - qu op v p = quant op v (mapAtomsFirstOrder f p) - co ((:~:) p) = mapAtomsFirstOrder f p - co (BinOp p op q) = binop (mapAtomsFirstOrder f p) op (mapAtomsFirstOrder f q) - tf flag = fromBool flag - at x = f x - --- | Deprecated - use mapAtoms -onatoms :: forall formula atom v. (FirstOrderFormula formula atom v) => (atom -> formula) -> formula -> formula -onatoms = mapAtomsFirstOrder - --- ------------------------------------------------------------------------- --- Formula analog of list iterator "itlist". --- ------------------------------------------------------------------------- - -foldAtomsFirstOrder :: FirstOrderFormula fof atom v => (r -> atom -> r) -> r -> fof -> r -foldAtomsFirstOrder f i fof = - foldFirstOrder qu co (const i) (f i) fof - where - qu _ _ fof' = foldAtomsFirstOrder f i fof' - co ((:~:) fof') = foldAtomsFirstOrder f i fof' - co (BinOp p _ q) = foldAtomsFirstOrder f (foldAtomsFirstOrder f i q) p - --- | Deprecated - use foldAtoms -overatoms :: forall formula atom v r. FirstOrderFormula formula atom v => - (atom -> r -> r) -> formula -> r -> r -overatoms f fm b = foldAtomsFirstOrder (flip f) b fm - --- ------------------------------------------------------------------------- --- Special case of a union of the results of a function over the atoms. --- ------------------------------------------------------------------------- - -atom_union :: forall formula atom v a. (FirstOrderFormula formula atom v, Ord a) => - (atom -> Set.Set a) -> formula -> Set.Set a -atom_union f fm = overatoms (\ h t -> Set.union (f h) t) fm Set.empty - --- |Just like Logic.FirstOrder.convertFOF except it rejects anything --- with a construct unsupported in a normal logic formula, --- i.e. quantifiers and formula combinators other than negation. -fromFirstOrder :: forall formula atom v lit atom2. - (Formula lit atom2, FirstOrderFormula formula atom v, Literal lit atom2) => - (atom -> atom2) -> formula -> Failing lit -fromFirstOrder ca formula = - foldFirstOrder (\ _ _ _ -> Failure ["fromFirstOrder"]) co (Success . fromBool) (Success . atomic . ca) formula - where - co :: Combination formula -> Failing lit - co ((:~:) f) = fromFirstOrder ca f >>= return . (.~.) - co _ = Failure ["fromFirstOrder"] - -fromLiteral :: forall lit atom v fof atom2. (Literal lit atom, FirstOrderFormula fof atom2 v) => - (atom -> atom2) -> lit -> fof -fromLiteral ca lit = foldLiteral (\ p -> (.~.) (fromLiteral ca p)) fromBool (atomic . ca) lit - -$(deriveSafeCopy 1 'base ''Quant) diff --git a/Data/Logic/Classes/Formula.hs b/Data/Logic/Classes/Formula.hs deleted file mode 100644 --- a/Data/Logic/Classes/Formula.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-} -module Data.Logic.Classes.Formula - ( Formula(atomic, foldAtoms, mapAtoms) - ) where - -class Formula formula atom | formula -> atom where - atomic :: atom -> formula - foldAtoms :: Formula formula atom => (r -> atom -> r) -> r -> formula -> r - mapAtoms :: Formula formula atom => (atom -> formula) -> formula -> formula diff --git a/Data/Logic/Classes/Literal.hs b/Data/Logic/Classes/Literal.hs deleted file mode 100644 --- a/Data/Logic/Classes/Literal.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, UndecidableInstances #-} -{-# OPTIONS -Wwarn #-} -module Data.Logic.Classes.Literal - ( Literal(..) - , zipLiterals - , toPropositional - , prettyLit - , foldAtomsLiteral - ) where - -import Data.Logic.Classes.Constants -import Data.Logic.Classes.Formula (Formula(atomic)) -import Data.Logic.Classes.Pretty (HasFixity(..), Fixity(..), FixityDirection(..)) -import qualified Data.Logic.Classes.Propositional as P -import Data.Logic.Classes.Negate -import Text.PrettyPrint (Doc, (<>), text, parens, nest) - --- |Literals are the building blocks of the clause and implicative normal --- |forms. They support negation and must include True and False elements. -class (Negatable lit, Constants lit, HasFixity atom, Formula lit atom, Ord lit) => Literal lit atom | lit -> atom where - foldLiteral :: (lit -> r) -> (Bool -> r) -> (atom -> r) -> lit -> r - -zipLiterals :: Literal lit atom => - (lit -> lit -> Maybe r) - -> (Bool -> Bool -> Maybe r) - -> (atom -> atom -> Maybe r) - -> lit -> lit -> Maybe r -zipLiterals neg tf at fm1 fm2 = - foldLiteral neg' tf' at' fm1 - where - neg' p1 = foldLiteral (neg p1) (\ _ -> Nothing) (\ _ -> Nothing) fm2 - tf' x1 = foldLiteral (\ _ -> Nothing) (tf x1) (\ _ -> Nothing) fm2 - at' a1 = foldLiteral (\ _ -> Nothing) (\ _ -> Nothing) (at a1) fm2 - -{- This makes bad things happen. --- | We can use an fof type as a lit, but it must not use some constructs. -instance FirstOrderFormula fof atom v => Literal fof atom v where - foldLiteral neg tf at fm = foldFirstOrder qu co tf at fm - where qu = error "instance Literal FirstOrderFormula" - co ((:~:) x) = neg x - co _ = error "instance Literal FirstOrderFormula" - atomic = Data.Logic.Classes.FirstOrder.atomic --} - -toPropositional :: forall lit atom pf atom2. (Literal lit atom, P.PropositionalFormula pf atom2) => - (atom -> atom2) -> lit -> pf -toPropositional ca lit = foldLiteral (\ p -> (.~.) (toPropositional ca p)) fromBool (atomic . ca) lit - -{- -prettyLit :: forall lit atom term v p f. (Literal lit atom v, Apply atom p term, Term term v f) => - (v -> Doc) - -> (p -> Doc) - -> (f -> Doc) - -> Int - -> lit - -> Doc -prettyLit pv pp pf _prec lit = - foldLiteral neg tf at lit - where - neg :: lit -> Doc - neg x = if negated x then text {-"¬"-} "~" <> prettyLit pv pp pf 5 x else prettyLit pv pp pf 5 x - tf = text . ifElse "true" "false" - at = foldApply (\ pr ts -> - pp pr <> case ts of - [] -> empty - _ -> parens (hcat (intersperse (text ",") (map (prettyTerm pv pf) ts)))) - (\ x -> text $ if x then "true" else "false") - -- parensIf False = id - -- parensIf _ = parens . nest 1 --} - -prettyLit :: forall lit atom v. (Literal lit atom) => - (Int -> atom -> Doc) - -> (v -> Doc) - -> Int - -> lit - -> Doc -prettyLit pa pv pprec lit = - parensIf (pprec > prec) $ foldLiteral co tf at lit - where - co :: lit -> Doc - co x = if negated x then text {-"¬"-} "~" <> prettyLit pa pv 5 x else prettyLit pa pv 5 x - tf x = text (if x then "true" else "false") - at = pa 6 - parensIf False = id - parensIf _ = parens . nest 1 - Fixity prec _ = fixityLiteral lit - -fixityLiteral :: (Literal formula atom) => formula -> Fixity -fixityLiteral formula = - foldLiteral neg tf at formula - where - neg _ = Fixity 5 InfixN - tf _ = Fixity 10 InfixN - at = fixity - -foldAtomsLiteral :: Literal lit atom => (r -> atom -> r) -> r -> lit -> r -foldAtomsLiteral f i lit = foldLiteral (foldAtomsLiteral f i) (const i) (f i) lit diff --git a/Data/Logic/Classes/Negate.hs b/Data/Logic/Classes/Negate.hs deleted file mode 100644 --- a/Data/Logic/Classes/Negate.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Data.Logic.Classes.Negate - ( Negatable(..) - , negated - , (.~.) - , (¬) - , negative - , positive - ) where - --- |The class of formulas that can be negated. There are some types --- that can be negated but do not support the other Boolean Logic --- operators, such as the 'Literal' class. -class Negatable formula where - -- | Negate a formula in a naive fashion, the operators below - -- prevent double negation. - negatePrivate :: formula -> formula - -- | Test whether a formula is negated or normal - foldNegation :: (formula -> r) -- ^ called for normal formulas - -> (formula -> r) -- ^ called for negated formulas - -> formula -> r --- | Is this formula negated at the top level? -negated :: Negatable formula => formula -> Bool -negated = foldNegation (const False) (not . negated) - --- | Negate the formula, avoiding double negation -(.~.) :: Negatable formula => formula -> formula -(.~.) = foldNegation negatePrivate id - -(¬) :: Negatable formula => formula -> formula -(¬) = (.~.) - -infix 5 .~., ¬ - --- ------------------------------------------------------------------------- --- Some operations on literals. (These names are used in Harrison's code.) --- ------------------------------------------------------------------------- - -negative :: Negatable formula => formula -> Bool -negative = negated - -positive :: Negatable formula => formula -> Bool -positive = not . negative diff --git a/Data/Logic/Classes/Pretty.hs b/Data/Logic/Classes/Pretty.hs deleted file mode 100644 --- a/Data/Logic/Classes/Pretty.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} -module Data.Logic.Classes.Pretty - ( Pretty(pretty) - , HasFixity(fixity) - , TH.Fixity(..) - , TH.FixityDirection(..) - , topFixity - , botFixity - ) where - -import qualified Language.Haskell.TH.Syntax as TH -import Text.PrettyPrint (Doc, text) - --- | The intent of this class is to be similar to Show, but only one --- way, with no corresponding Read class. It doesn't really belong --- here in logic-classes. To put something in a pretty printing class --- implies that there is only one way to pretty print it, which is not --- an assumption made by Text.PrettyPrint. But in practice this is --- often good enough. -class Pretty x where - pretty :: x -> Doc - --- | A class used to do proper parenthesization of formulas. If we --- nest a higher precedence formula inside a lower one parentheses can --- be omitted. Because @|@ has lower precedence than @&@, the formula --- @a | (b & c)@ appears as @a | b & c@, while @(a | b) & c@ appears --- unchanged. (Name Precedence chosen because Fixity was taken.) --- --- The second field of Fixity is the FixityDirection, which can be --- left, right, or non. A left associative operator like @/@ is --- grouped left to right, so parenthese can be omitted from @(a / b) / --- c@ but not from @a / (b / c)@. It is a syntax error to omit --- parentheses when formatting a non-associative operator. --- --- The Haskell FixityDirection type is concerned with how to interpret --- a formula formatted in a certain way, but here we are concerned --- with how to format a formula given its interpretation. As such, --- one case the Haskell type does not capture is whether the operator --- follows the associative law, so we can omit parentheses in an --- expression such as @a & b & c@. -class HasFixity x where - fixity :: x -> TH.Fixity - --- Definitions from template-haskell: --- data Fixity = Fixity Int FixityDirection --- data FixityDirection = InfixL | InfixR | InfixN - --- | This is used as the initial value for the parent fixity. -topFixity :: TH.Fixity -topFixity = TH.Fixity 0 TH.InfixN - --- | This is used as the fixity for things that never need --- parenthesization, such as function application. -botFixity :: TH.Fixity -botFixity = TH.Fixity 10 TH.InfixN - -instance Pretty String where - pretty = text diff --git a/Data/Logic/Classes/Propositional.hs b/Data/Logic/Classes/Propositional.hs deleted file mode 100644 --- a/Data/Logic/Classes/Propositional.hs +++ /dev/null @@ -1,333 +0,0 @@ --- | PropositionalFormula is a multi-parameter type class for --- representing instance of propositional (aka zeroth order) logic --- datatypes. These are formulas which have truth values, but no "for --- all" or "there exists" quantifiers and thus no variables or terms --- as we have in first order or predicate logic. It is intended that --- we will be able to write instances for various different --- implementations to allow these systems to interoperate. The --- operator names were adopted from the Logic-TPTP package. -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, - MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TemplateHaskell, UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.Logic.Classes.Propositional - ( PropositionalFormula(..) - , showPropositional - , prettyPropositional - , fixityPropositional - , convertProp - , combine - , negationNormalForm - , clauseNormalForm - , clauseNormalForm' - , clauseNormalFormAlt - , clauseNormalFormAlt' - , disjunctiveNormalForm - , disjunctiveNormalForm' - , overatoms - , foldAtomsPropositional - , mapAtomsPropositional - ) where - -import Data.Logic.Classes.Combine -import Data.Logic.Classes.Constants (Constants(fromBool), asBool, prettyBool) -import Data.Logic.Classes.Formula (Formula(atomic)) -import Data.Logic.Classes.Negate -import Data.Logic.Classes.Pretty (Pretty, HasFixity(fixity), Fixity(Fixity), FixityDirection(..)) -import Data.SafeCopy (base, deriveSafeCopy) -import qualified Data.Set.Extra as Set -import Text.PrettyPrint (Doc, text, (<>)) - --- |A type class for propositional logic. If the type we are writing --- an instance for is a zero-order (aka propositional) logic type --- there will generally by a type or a type parameter corresponding to --- atom. For first order or predicate logic types, it is generally --- easiest to just use the formula type itself as the atom type, and --- raise errors in the implementation if a non-atomic formula somehow --- appears where an atomic formula is expected (i.e. as an argument to --- atomic or to the third argument of foldPropositional.) --- --- The Ord superclass is required so we can put formulas in sets --- during the normal form computations. Negatable and Combinable are --- also considered basic operations that we can't build this package --- without. It is less obvious whether Constants is always required, --- but the implementation of functions like simplify would be more --- elaborate if we didn't have it, so we will require it. -class (Ord formula, Negatable formula, Combinable formula, Constants formula, - Pretty formula, HasFixity formula, Formula formula atom) => PropositionalFormula formula atom | formula -> atom where - -- | Build an atomic formula from the atom type. - -- | A fold function that distributes different sorts of formula - -- to its parameter functions, one to handle binary operators, one - -- for negations, and one for atomic formulas. See examples of its - -- use to implement the polymorphic functions below. - foldPropositional :: (Combination formula -> r) - -> (Bool -> r) - -> (atom -> r) - -> formula -> r - --- | Show a formula in a format that can be evaluated -showPropositional :: (PropositionalFormula formula atom) => (atom -> String) -> formula -> String -showPropositional showAtom formula = - foldPropositional co tf at formula - where - co ((:~:) f) = "(.~.) " ++ parenForm f - co (BinOp f1 op f2) = parenForm f1 ++ " " ++ showFormOp op ++ " " ++ parenForm f2 - tf True = "true" - tf False = "false" - at = showAtom - parenForm x = "(" ++ showPropositional showAtom x ++ ")" - showFormOp (:<=>:) = ".<=>." - showFormOp (:=>:) = ".=>." - showFormOp (:&:) = ".&." - showFormOp (:|:) = ".|." - --- | Show a formula in a visually pleasing format. -prettyPropositional :: (PropositionalFormula formula atom, HasFixity formula) => - (atom -> Doc) - -> Fixity -- ^ The fixity of the parent formula. If the operator being formatted here - -- has a lower precedence it needs to be parenthesized. - -> formula - -> Doc -prettyPropositional prettyAtom (Fixity pprec _pdir) formula = - parenIf (pprec > prec) (foldPropositional co tf at formula) - where - co ((:~:) f) = text "¬" <> prettyPropositional prettyAtom fix f - co (BinOp f1 op f2) = prettyPropositional prettyAtom fix f1 <> text " " <> prettyBinOp op <> text " " <> prettyPropositional prettyAtom fix f2 - tf = prettyBool - at = prettyAtom - -- parenForm x = cat [text "(", prettyPropositional prettyAtom 0 x, text ")"] - parenIf True x = text "(" <> x <> text ")" - parenIf False x = x - fix@(Fixity prec _dir) = fixity formula - -fixityPropositional :: (HasFixity atom, PropositionalFormula formula atom) => formula -> Fixity -fixityPropositional formula = - foldPropositional co tf at formula - where - co ((:~:) _) = Fixity 5 InfixN - co (BinOp _ (:&:) _) = Fixity 4 InfixL - co (BinOp _ (:|:) _) = Fixity 3 InfixL - co (BinOp _ (:=>:) _) = Fixity 2 InfixR - co (BinOp _ (:<=>:) _) = Fixity 1 InfixL - tf _ = Fixity 10 InfixN - at = fixity - --- |Convert any instance of a propositional logic expression to any --- other using the supplied atom conversion function. -convertProp :: forall formula1 atom1 formula2 atom2. - (PropositionalFormula formula1 atom1, - PropositionalFormula formula2 atom2) => - (atom1 -> atom2) -> formula1 -> formula2 -convertProp convertA formula = - foldPropositional c fromBool a formula - where - convert' = convertProp convertA - c ((:~:) f) = (.~.) (convert' f) - c (BinOp f1 op f2) = combine (BinOp (convert' f1) op (convert' f2)) - a = atomic . convertA - --- | Simplify and recursively apply nnf. -negationNormalForm :: (PropositionalFormula formula atom) => formula -> formula -negationNormalForm = nnf . psimplify - --- |Eliminate => and <=> and move negations inwards: --- --- @ --- Formula Rewrites to --- P => Q ~P | Q --- P <=> Q (P & Q) | (~P & ~Q) --- ~∀X P ∃X ~P --- ~∃X P ∀X ~P --- ~(P & Q) (~P | ~Q) --- ~(P | Q) (~P & ~Q) --- ~~P P --- @ --- -nnf :: (PropositionalFormula formula atom) => formula -> formula -nnf fm = foldPropositional (nnfCombine fm) fromBool (\ _ -> fm) fm - -nnfCombine :: (PropositionalFormula formula atom) => formula -> Combination formula -> formula -nnfCombine fm ((:~:) p) = foldPropositional nnfNotCombine (fromBool . not) (\ _ -> fm) p -nnfCombine _ (BinOp p (:=>:) q) = nnf ((.~.) p) .|. (nnf q) -nnfCombine _ (BinOp p (:<=>:) q) = (nnf p .&. nnf q) .|. (nnf ((.~.) p) .&. nnf ((.~.) q)) -nnfCombine _ (BinOp p (:&:) q) = nnf p .&. nnf q -nnfCombine _ (BinOp p (:|:) q) = nnf p .|. nnf q - -nnfNotCombine :: (PropositionalFormula formula atom) => Combination formula -> formula -nnfNotCombine ((:~:) p) = nnf p -nnfNotCombine (BinOp p (:&:) q) = nnf ((.~.) p) .|. nnf ((.~.) q) -nnfNotCombine (BinOp p (:|:) q) = nnf ((.~.) p) .&. nnf ((.~.) q) -nnfNotCombine (BinOp p (:=>:) q) = nnf p .&. nnf ((.~.) q) -nnfNotCombine (BinOp p (:<=>:) q) = (nnf p .&. nnf ((.~.) q)) .|. nnf ((.~.) p) .&. nnf q - --- |Do a bottom-up recursion to simplify a propositional formula. -psimplify :: (PropositionalFormula formula atom) => formula -> formula -psimplify fm = - foldPropositional co tf at fm - where - co ((:~:) p) = psimplify1 ((.~.) (psimplify p)) - co (BinOp p (:&:) q) = psimplify1 (psimplify p .&. psimplify q) - co (BinOp p (:|:) q) = psimplify1 (psimplify p .|. psimplify q) - co (BinOp p (:=>:) q) = psimplify1 (psimplify p .=>. psimplify q) - co (BinOp p (:<=>:) q) = psimplify1 (psimplify p .<=>. psimplify q) - tf _ = fm - at _ = fm - --- |Do one step of simplify for propositional formulas: --- Perform the following transformations everywhere, plus any --- commuted versions for &, |, and <=>. --- --- @ --- ~False -> True --- ~True -> False --- True & P -> P --- False & P -> False --- True | P -> True --- False | P -> P --- True => P -> P --- False => P -> True --- P => True -> P --- P => False -> True --- True <=> P -> P --- False <=> P -> ~P --- @ --- -psimplify1 :: forall formula atom. (PropositionalFormula formula atom) => formula -> formula -psimplify1 fm = - foldPropositional simplifyCombine (\ _ -> fm) (\ _ -> fm) fm - where - simplifyCombine ((:~:) f) = foldPropositional simplifyNotCombine (fromBool . not) simplifyNotAtom f - simplifyCombine (BinOp l op r) = - case (asBool l, op, asBool r) of - (Just True, (:&:), _) -> r - (Just False, (:&:), _) -> fromBool False - (_, (:&:), Just True) -> l - (_, (:&:), Just False) -> fromBool False - (Just True, (:|:), _) -> fromBool True - (Just False, (:|:), _) -> r - (_, (:|:), Just True) -> fromBool True - (_, (:|:), Just False) -> l - (Just True, (:=>:), _) -> r - (Just False, (:=>:), _) -> fromBool True - (_, (:=>:), Just True) -> fromBool True - (_, (:=>:), Just False) -> (.~.) l - (Just False, (:<=>:), Just False) -> fromBool True - (Just True, (:<=>:), _) -> r - (Just False, (:<=>:), _) -> (.~.) r - (_, (:<=>:), Just True) -> l - (_, (:<=>:), Just False) -> (.~.) l - _ -> fm - simplifyNotCombine ((:~:) f) = f - simplifyNotCombine _ = fm - simplifyNotAtom x = (.~.) (atomic x) - -clauseNormalForm' :: (PropositionalFormula formula atom) => formula -> Set.Set (Set.Set formula) -clauseNormalForm' = simp purecnf . negationNormalForm - -clauseNormalForm :: forall formula atom. (PropositionalFormula formula atom) => formula -> formula -clauseNormalForm formula = - case clean (lists cnf) of - [] -> fromBool True - xss -> foldr1 (.&.) . map (foldr1 (.|.)) $ xss - where - clean = filter (not . null) - lists = Set.toList . Set.map Set.toList - cnf = clauseNormalForm' formula - --- |I'm not sure of the clauseNormalForm functions above are wrong or just different. -clauseNormalFormAlt' :: (PropositionalFormula formula atom) => formula -> Set.Set (Set.Set formula) -clauseNormalFormAlt' = simp purecnf' . negationNormalForm - -clauseNormalFormAlt :: forall formula atom. (PropositionalFormula formula atom) => formula -> formula -clauseNormalFormAlt formula = - case clean (lists cnf) of - [] -> fromBool True - xss -> foldr1 (.&.) . map (foldr1 (.|.)) $ xss - where - clean = filter (not . null) - lists = Set.toList . Set.map Set.toList - cnf = clauseNormalFormAlt' formula - -disjunctiveNormalForm :: (PropositionalFormula formula atom) => formula -> formula -disjunctiveNormalForm formula = - case clean (lists dnf) of - [] -> fromBool False - xss -> foldr1 (.|.) . map (foldr1 (.&.)) $ xss - where - clean = filter (not . null) - lists = Set.toList . Set.map Set.toList - dnf = disjunctiveNormalForm' formula - -disjunctiveNormalForm' :: (PropositionalFormula formula atom, Eq formula) => formula -> Set.Set (Set.Set formula) -disjunctiveNormalForm' = simp purednf . negationNormalForm - -simp :: forall formula atom. (PropositionalFormula formula atom) => - (formula -> Set.Set (Set.Set formula)) -> formula -> Set.Set (Set.Set formula) -simp purenf fm = - case (compare fm (fromBool False), compare fm (fromBool True)) of - (EQ, _) -> Set.empty - (_, EQ) -> Set.singleton Set.empty - _ ->cjs' - where - -- Discard any clause that is the proper subset of another clause - cjs' = Set.filter keep cjs - keep x = not (Set.or (Set.map (Set.isProperSubsetOf x) cjs)) - cjs = Set.filter (not . trivial) (purenf (nnf fm)) :: Set.Set (Set.Set formula) - --- |Harrison page 59. Look for complementary pairs in a clause. -trivial :: (Negatable lit, Ord lit) => Set.Set lit -> Bool -trivial lits = - not . Set.null $ Set.intersection (Set.map (.~.) n) p - where (n, p) = Set.partition negated lits - -purecnf :: forall formula atom. (PropositionalFormula formula atom) => formula -> Set.Set (Set.Set formula) -purecnf fm = Set.map (Set.map (.~.)) (purednf (nnf ((.~.) fm))) - -purednf :: forall formula atom. (PropositionalFormula formula atom) => formula -> Set.Set (Set.Set formula) -purednf fm = - foldPropositional c (\ _ -> x) (\ _ -> x) fm - where - c :: Combination formula -> Set.Set (Set.Set formula) - c (BinOp p (:&:) q) = Set.distrib (purednf p) (purednf q) - c (BinOp p (:|:) q) = Set.union (purednf p) (purednf q) - c _ = x - x :: Set.Set (Set.Set formula) - x = Set.singleton (Set.singleton (convertProp id fm)) :: Set.Set (Set.Set formula) - -purecnf' :: forall formula atom. (PropositionalFormula formula atom) => formula -> Set.Set (Set.Set formula) -purecnf' fm = - foldPropositional c (\ _ -> x) (\ _ -> x) fm - where - c :: Combination formula -> Set.Set (Set.Set formula) - c (BinOp p (:&:) q) = Set.union (purecnf' p) (purecnf' q) - c (BinOp p (:|:) q) = Set.distrib (purecnf' p) (purecnf' q) - c _ = x - x :: Set.Set (Set.Set formula) - x = Set.singleton (Set.singleton (convertProp id fm)) :: Set.Set (Set.Set formula) - --- ------------------------------------------------------------------------- --- Formula analog of list iterator "itlist". --- ------------------------------------------------------------------------- - --- | Use this to implement foldAtoms -foldAtomsPropositional :: PropositionalFormula pf atom => (r -> atom -> r) -> r -> pf -> r -foldAtomsPropositional f i pf = - foldPropositional co (const i) (f i) pf - where - co ((:~:) pf') = foldAtomsPropositional f i pf' - co (BinOp p _ q) = foldAtomsPropositional f (foldAtomsPropositional f i q) p - --- | Deprecated - use foldAtoms. -overatoms :: forall formula atom r. PropositionalFormula formula atom => (atom -> r -> r) -> formula -> r -> r -overatoms f fm b = foldAtomsPropositional (flip f) b fm - -mapAtomsPropositional :: forall formula atom. PropositionalFormula formula atom => (atom -> formula) -> formula -> formula -mapAtomsPropositional f fm = - foldPropositional co tf at fm - where - co ((:~:) p) = mapAtomsPropositional f p - co (BinOp p op q) = binop (mapAtomsPropositional f p) op (mapAtomsPropositional f q) - tf flag = fromBool flag - at x = f x - -$(deriveSafeCopy 1 'base ''BinOp) -$(deriveSafeCopy 1 'base ''Combination) diff --git a/Data/Logic/Classes/Skolem.hs b/Data/Logic/Classes/Skolem.hs deleted file mode 100644 --- a/Data/Logic/Classes/Skolem.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-} -module Data.Logic.Classes.Skolem where - -import Data.Logic.Classes.Variable (Variable) - --- |This class shows how to convert between atomic Skolem functions --- and Ints. We include a variable type as a parameter because we --- create skolem functions to replace an existentially quantified --- variable, and it can be helpful to retain a reference to the --- variable. -class Variable v => Skolem f v | f -> v where - toSkolem :: v -> f - -- ^ Built a Skolem function from the given variable and number. - -- The number is generally obtained from the skolem monad. - isSkolem :: f -> Bool diff --git a/Data/Logic/Classes/Term.hs b/Data/Logic/Classes/Term.hs deleted file mode 100644 --- a/Data/Logic/Classes/Term.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-} -module Data.Logic.Classes.Term - ( Term(..) - , Function - , convertTerm - , showTerm - , prettyTerm - , fvt - , tsubst - , funcs - ) where - -import Data.Generics (Data) -import Data.List (intercalate, intersperse) -import Data.Logic.Classes.Pretty (Pretty) -import Data.Logic.Classes.Skolem -import Data.Logic.Classes.Variable -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import qualified Data.Set as Set -import Text.PrettyPrint (Doc, (<>), brackets, hcat, text) - -class (Eq f, Ord f, Skolem f v, Data f, Pretty f) => Function f v - -class ( Ord term -- For implementing Ord in Literal - , Variable v - , Function f v ) => Term term v f | term -> v f where - vt :: v -> term - -- ^ Build a term which is a variable reference. - fApp :: f -> [term] -> term - -- ^ Build a term by applying terms to an atomic function. @f@ - -- (atomic function) is one of the type parameters, this package - -- is mostly indifferent to its internal structure. - foldTerm :: (v -> r) -> (f -> [term] -> r) -> term -> r - -- ^ A fold for the term data type, which understands terms built - -- from a variable and a term built from the application of a - -- primitive function to other terms. - zipTerms :: (v -> v -> Maybe r) -> (f -> [term] -> f -> [term] -> Maybe r) -> term -> term -> Maybe r - -convertTerm :: forall term1 v1 f1 term2 v2 f2. - (Term term1 v1 f1, - Term term2 v2 f2) => - (v1 -> v2) -> (f1 -> f2) -> term1 -> term2 -convertTerm convertV convertF term = - foldTerm v fn term - where - convertTerm' = convertTerm convertV convertF - v = vt . convertV - fn x ts = fApp (convertF x) (map convertTerm' ts) - -showTerm :: forall term v f. (Term term v f, Show v, Show f) => - term -> String -showTerm term = - foldTerm v f term - where - v :: v -> String - v v' = "vt (" ++ show v' ++ ")" - f :: f -> [term] -> String - f fn ts = "fApp (" ++ show fn ++ ") [" ++ intercalate "," (map showTerm ts) ++ "]" - -prettyTerm :: forall v f term. (Term term v f) => - (v -> Doc) - -> (f -> Doc) - -> term - -> Doc -prettyTerm pv pf t = foldTerm pv (\ fn ts -> pf fn <> brackets (hcat (intersperse (text ",") (map (prettyTerm pv pf) ts)))) t - -fvt :: (Term term v f, Ord v) => term -> Set.Set v -fvt tm = foldTerm Set.singleton (\ _ args -> Set.unions (map fvt args)) tm - --- ------------------------------------------------------------------------- --- Substitution within terms. --- ------------------------------------------------------------------------- - -tsubst :: (Term term v f, Ord v) => Map.Map v term -> term -> term -tsubst sfn tm = foldTerm (\ x -> fromMaybe tm (Map.lookup x sfn)) (\ fn args -> fApp fn (map (tsubst sfn) args)) tm - -funcs :: (Term term v f, Ord f) => term -> Set.Set (f, Int) -funcs tm = - foldTerm (const Set.empty) - (\ f args -> foldr (\ arg r -> Set.union (funcs arg) r) (Set.singleton (f, length args)) args) - tm diff --git a/Data/Logic/Classes/Variable.hs b/Data/Logic/Classes/Variable.hs deleted file mode 100644 --- a/Data/Logic/Classes/Variable.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Data.Logic.Classes.Variable - ( Variable(..) - , variants - , showVariable - ) where - -import Data.Data (Data) -import Data.Logic.Classes.Pretty (Pretty) -import qualified Data.Set as Set -import Data.String (IsString) -import Text.PrettyPrint (Doc) - -class (Ord v, IsString v, Data v, Pretty v) => Variable v where - variant :: v -> Set.Set v -> v - -- ^ Return a variable based on v but different from any set - -- element. The result may be v itself if v is not a member of - -- the set. - prefix :: String -> v -> v - -- ^ Modify a variable by adding a prefix. This unfortunately - -- assumes that v is "string-like" but at least one algorithm in - -- Harrison currently requires this. - prettyVariable :: v -> Doc - -- ^ Pretty print a variable - --- | Return an infinite list of variations on v -variants :: Variable v => v -> [v] -variants v0 = - iter' Set.empty v0 - where iter' s v = let v' = variant v s in v' : iter' (Set.insert v s) v' - -showVariable :: Variable v => v -> String -showVariable v = "fromString (" ++ show (show (prettyVariable v)) ++ ")" diff --git a/Data/Logic/Failing.hs b/Data/Logic/Failing.hs deleted file mode 100644 --- a/Data/Logic/Failing.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.Logic.Failing - ( Failing(Success, Failure) - , failing - ) where - -import Control.Applicative.Error -import Data.Generics - -failing :: ([String] -> b) -> (a -> b) -> Failing a -> b -failing f _ (Failure errs) = f errs -failing _ f (Success a) = f a - -instance Monad Failing where - return = Success - m >>= f = - case m of - (Failure errs) -> (Failure errs) - (Success a) -> f a - fail errMsg = Failure [errMsg] - -deriving instance Typeable1 Failing -deriving instance Data a => Data (Failing a) -deriving instance Read a => Read (Failing a) -deriving instance Eq a => Eq (Failing a) -deriving instance Ord a => Ord (Failing a) diff --git a/Data/Logic/HUnit.hs b/Data/Logic/HUnit.hs deleted file mode 100644 --- a/Data/Logic/HUnit.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, RankNTypes #-} -module Data.Logic.HUnit - ( Test(..) - , Assertion - , T.assertEqual - , convert - , TestFormula - , TestFormulaEq - ) where - -import Data.Logic.Classes.Apply (Apply) -import Data.Logic.Classes.Equals (AtomEq) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula) -import Data.Logic.Classes.Term (Term) -import Data.Logic.Types.Harrison.FOL (Function(..)) -import Data.String (IsString(fromString)) -import qualified Test.HUnit as T - -type Assertion t = IO () - --- | HUnit Test type with an added phantom type parameter. To run --- such a test you use the convert function below: --- @ --- :load Data.Logic.Tests.Harrison.Meson --- :m +Data.Logic.Tests.HUnit --- :m +Test.HUnit --- runTestTT (convert tests) --- @ -data Test t - = TestCase (Assertion t) - | TestList [Test t] - | TestLabel String (Test t) - | Test0 T.Test - -convert :: Test t -> T.Test -convert (TestCase assertion) = T.TestCase assertion -convert (TestList tests) = T.TestList (map convert tests) -convert (TestLabel label test) = T.TestLabel label (convert test) -convert (Test0 test) = test - -class (FirstOrderFormula formula atom v, - Apply atom p term, - Term term v f, - Eq formula, Ord formula, Show formula, - Eq p, - IsString v, IsString p, IsString f, Ord f, Ord p, - Eq term, Show term, Ord term, - Show v) => TestFormula formula atom term v p f - -class (FirstOrderFormula formula atom v, - AtomEq atom p term, - Term term v f, - Eq formula, Ord formula, Show formula, - Eq p, - IsString v, IsString p, IsString f, Ord f, Ord p, - Eq term, Show term, Ord term, - Show v) => TestFormulaEq formula atom term v p f - -{- -type Test' = forall formula atom term v p f. TestFormula formula atom term v p f => Test formula -type Formula' = forall formula atom term v p f. TestFormula formula atom term v p f => formula -type TestEq' = forall formula atom term v p f. TestFormulaEq formula atom term v p f => Test formula -type FormulaEq' = forall formula atom term v p f. TestFormulaEq formula atom term v p f => formula --} diff --git a/Data/Logic/Harrison/DP.hs b/Data/Logic/Harrison/DP.hs deleted file mode 100644 --- a/Data/Logic/Harrison/DP.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, ScopedTypeVariables #-} -module Data.Logic.Harrison.DP - ( tests - , dpll - ) where - -import Control.Applicative.Error (Failing(..)) -import Data.Logic.Classes.Literal (Literal) -import Data.Logic.Classes.Negate (Negatable, (.~.), negated) -import Data.Logic.Classes.Propositional (PropositionalFormula(..)) -import Data.Logic.Harrison.DefCNF (NumAtom(..), defcnfs) -import Data.Logic.Harrison.Lib (allpairs, maximize', minimize', defined, setmapfilter, (|->)) -import Data.Logic.Harrison.Prop (negative, positive, trivial, tautology, cnf) -import Data.Logic.Harrison.PropExamples (Atom(..), N, prime) -import Data.Logic.HUnit -import Data.Logic.Types.Propositional (Formula(..)) -import qualified Data.Map as Map -import qualified Data.Set.Extra as Set - -import Debug.Trace - -instance NumAtom (Atom N) where - ma n = P "p" n Nothing - ai (P _ n _) = n - -tests = convert (TestList [test01, test02, test03]) - --- ========================================================================= --- The Davis-Putnam and Davis-Putnam-Loveland-Logemann procedures. --- --- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) --- ========================================================================= - --- ------------------------------------------------------------------------- --- The DP procedure. --- ------------------------------------------------------------------------- - -one_literal_rule :: (Literal lit atom, Ord lit) => Set.Set (Set.Set lit) -> Failing (Set.Set (Set.Set lit)) -one_literal_rule clauses = - case Set.minView (Set.filter (\ cl -> Set.size cl == 1) clauses) of - Nothing -> Failure ["one_literal_rule"] - Just (s, _) -> - let u = Set.findMin s in - let u' = (.~.) u in - let clauses1 = Set.filter (\ cl -> not (Set.member u cl)) clauses in - Success (Set.map (\ cl -> Set.delete u' cl) clauses1) - -affirmative_negative_rule :: (Literal lit atom, Ord lit) => Set.Set (Set.Set lit) -> Failing (Set.Set (Set.Set lit)) -affirmative_negative_rule clauses = - let (neg',pos) = Set.partition negative (Set.flatten clauses) in - let neg = Set.map (.~.) neg' in - let pos_only = Set.difference pos neg - neg_only = Set.difference neg pos in - let pure = Set.union pos_only (Set.map (.~.) neg_only) in - if Set.null pure - then Failure ["affirmative_negative_rule"] - else Success (Set.filter (\ cl -> Set.null (Set.intersection cl pure)) clauses) - -resolve_on :: forall lit atom. (Literal lit atom, Ord lit) => - lit -> Set.Set (Set.Set lit) -> Set.Set (Set.Set lit) -resolve_on p clauses = - let p' = (.~.) p - (pos,notpos) = Set.partition (Set.member p) clauses in - let (neg,other) = Set.partition (Set.member p') notpos in - let pos' = Set.map (Set.filter (\ l -> l /= p)) pos - neg' = Set.map (Set.filter (\ l -> l /= p')) neg in - let res0 = allpairs Set.union pos' neg' in - Set.union other (Set.filter (not . trivial) res0) - -resolution_blowup :: forall formula. (Negatable formula, Ord formula) => - Set.Set (Set.Set formula) -> formula -> Int -resolution_blowup cls l = - let m = Set.size (Set.filter (Set.member l) cls) - n = Set.size (Set.filter (Set.member ((.~.) l)) cls) in - m * n - m - n - -resolution_rule :: forall lit atom. (Literal lit atom, Ord lit) => - Set.Set (Set.Set lit) -> Failing (Set.Set (Set.Set lit)) -resolution_rule clauses = - let pvs = Set.filter positive (Set.flatten clauses) in - case minimize' (resolution_blowup clauses) pvs of - Just p -> Success (resolve_on p clauses) - Nothing -> Failure ["resolution_rule"] - --- ------------------------------------------------------------------------- --- Overall procedure. --- ------------------------------------------------------------------------- - -dp :: forall lit atom. (Literal lit atom, Ord lit) => Set.Set (Set.Set lit) -> Failing Bool -dp clauses = - if Set.null clauses - then Success True - else if Set.member Set.empty clauses - then Success False - else case one_literal_rule clauses >>= dp of - Success x -> Success x - Failure _ -> - case affirmative_negative_rule clauses >>= dp of - Success x -> Success x - Failure _ -> resolution_rule clauses >>= dp - --- ------------------------------------------------------------------------- --- Davis-Putnam satisfiability tester and tautology checker. --- ------------------------------------------------------------------------- - -dpsat :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom, NumAtom atom, Ord pf) => pf -> Failing Bool -dpsat fm = dp (defcnfs fm :: Set.Set (Set.Set pf)) - -dptaut :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom, NumAtom atom, Ord pf) => pf -> Failing Bool -dptaut fm = dpsat((.~.) fm) >>= return . not - --- ------------------------------------------------------------------------- --- Examples. --- ------------------------------------------------------------------------- - -test01 = TestCase (assertEqual "dptaut(prime 11)" (Success True) (dptaut(prime 11 :: Formula (Atom N)))) - --- ------------------------------------------------------------------------- --- The same thing but with the DPLL procedure. --- ------------------------------------------------------------------------- - -posneg_count :: forall formula. (Negatable formula, Ord formula) => - Set.Set (Set.Set formula) -> formula -> Int -posneg_count cls l = - let m = Set.size(Set.filter (Set.member l) cls) - n = Set.size(Set.filter (Set.member ((.~.) l)) cls) in - m + n - -dpll :: forall lit atom. (Literal lit atom, Ord lit) => - Set.Set (Set.Set lit) -> Failing Bool -dpll clauses = - if clauses == Set.empty - then Success True - else if Set.member Set.empty clauses - then Success False - else case one_literal_rule clauses >>= dpll of - Success x -> Success x - Failure _ -> - case affirmative_negative_rule clauses >>= dpll of - Success x -> Success x - Failure _ -> - let pvs = Set.filter positive (Set.flatten clauses) in - case maximize' (posneg_count clauses) pvs of - Nothing -> Failure ["dpll"] - Just p -> - case (dpll (Set.insert (Set.singleton p) clauses), dpll (Set.insert (Set.singleton ((.~.) p)) clauses)) of - (Success a, Success b) -> Success (a || b) - (Failure a, Failure b) -> Failure (a ++ b) - (Failure a, _) -> Failure a - (_, Failure b) -> Failure b - -dpllsat :: forall pf. (PropositionalFormula pf (Atom N), Literal pf (Atom N), Ord pf) => - pf -> Failing Bool -dpllsat fm = dpll(defcnfs fm :: Set.Set (Set.Set pf)) - -dplltaut :: forall pf. (PropositionalFormula pf (Atom N), Literal pf (Atom N), Ord pf) => - pf -> Failing Bool -dplltaut fm = dpllsat ((.~.) fm) >>= return . not - --- ------------------------------------------------------------------------- --- Example. --- ------------------------------------------------------------------------- - -test02 = TestCase (assertEqual "dplltaut(prime 11)" (Success True) (dplltaut(prime 11 :: Formula (Atom N)))) - --- ------------------------------------------------------------------------- --- Iterative implementation with explicit trail instead of recursion. --- ------------------------------------------------------------------------- - -data TrailMix = Guessed | Deduced deriving (Eq, Ord) - -unassigned :: forall formula. (Negatable formula, Ord formula) => - Set.Set (Set.Set formula) -> Set.Set (formula, TrailMix) -> Set.Set formula -unassigned cls trail = - Set.difference (Set.flatten (Set.map (Set.map litabs) cls)) (Set.map (litabs . fst) trail) - where litabs p = if negated p then (.~.) p else p - -unit_subpropagate :: forall formula. (Negatable formula, Ord formula) => - (Set.Set (Set.Set formula), Map.Map formula (), Set.Set (formula, TrailMix)) - -> (Set.Set (Set.Set formula), Map.Map formula (), Set.Set (formula, TrailMix)) -unit_subpropagate (cls,fn,trail) = - let cls' = Set.map (Set.filter (not . defined fn . (.~.))) cls in - let uu cs = - case Set.minView cs of - Nothing -> Failure ["unit_subpropagate"] - Just (c, _) -> if Set.size cs == 1 && not (defined fn c) - then Success cs - else Failure ["unit_subpropagate"] in - let newunits = Set.flatten (setmapfilter uu cls') in - if Set.null newunits then (cls',fn,trail) else - let trail' = Set.fold (\ p t -> Set.insert (p,Deduced) t) trail newunits - fn' = Set.fold (\ u -> (u |-> ())) fn newunits in - unit_subpropagate (cls',fn',trail') - -unit_propagate :: forall t. (Negatable t, Ord t) => - (Set.Set (Set.Set t), Set.Set (t, TrailMix)) - -> (Set.Set (Set.Set t), Set.Set (t, TrailMix)) -unit_propagate (cls,trail) = - let fn = Set.fold (\ (x,_) -> (x |-> ())) Map.empty trail in - let (cls',fn',trail') = unit_subpropagate (cls,fn,trail) in (cls',trail') - -backtrack :: forall t. Set.Set (t, TrailMix) -> Set.Set (t, TrailMix) -backtrack trail = - case Set.minView trail of - Just ((p,Deduced), tt) -> backtrack tt - _ -> trail - -dpli :: forall atomic pf. (PropositionalFormula pf atomic, Ord pf) => - Set.Set (Set.Set pf) -> Set.Set (pf, TrailMix) -> Failing Bool -dpli cls trail = - let (cls', trail') = unit_propagate (cls, trail) in - if Set.member Set.empty cls' then - case Set.minView trail of - Just ((p,Guessed), tt) -> dpli cls (Set.insert ((.~.) p, Deduced) tt) - _ -> Success False - else - case unassigned cls (trail' :: Set.Set (pf, TrailMix)) of - s | Set.null s -> Success True - ps -> case maximize' (posneg_count cls') ps of - Just p -> dpli cls (Set.insert (p :: pf, Guessed) trail') - Nothing -> Failure ["dpli"] - -dplisat :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom, NumAtom atom, Ord pf) => - pf -> Failing Bool -dplisat fm = dpli (defcnfs fm :: Set.Set (Set.Set pf)) Set.empty - -dplitaut :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom, NumAtom atom, Ord pf) => - pf -> Failing Bool -dplitaut fm = dplisat((.~.) fm) >>= return . not - --- ------------------------------------------------------------------------- --- With simple non-chronological backjumping and learning. --- ------------------------------------------------------------------------- - -backjump :: forall a. (Negatable a, Ord a) => - Set.Set (Set.Set a) -> a -> Set.Set (a, TrailMix) -> Set.Set (a, TrailMix) -backjump cls p trail = - case Set.minView (backtrack trail) of - Just ((q,Guessed), tt) -> - let (cls',trail') = unit_propagate (cls, Set.insert (p,Guessed) tt) in - if Set.member Set.empty cls' then backjump cls p tt else trail - _ -> trail - -dplb :: forall a. (Negatable a, Ord a) => - Set.Set (Set.Set a) -> Set.Set (a, TrailMix) -> Failing Bool -dplb cls trail = - let (cls',trail') = unit_propagate (cls,trail) in - if Set.member Set.empty cls' then - case Set.minView (backtrack trail) of - Just ((p,Guessed), tt) -> - let trail'' = backjump cls p tt in - let declits = Set.filter (\ (_,d) -> d == Guessed) trail'' in - let conflict = Set.insert ((.~.) p) (Set.map ((.~.) . fst) declits) in - dplb (Set.insert conflict cls) (Set.insert ((.~.) p,Deduced) trail'') - _ -> Success False - else - case unassigned cls trail' of - s | Set.null s -> Success True - ps -> case maximize' (posneg_count cls') ps of - Just p -> dplb cls (Set.insert (p,Guessed) trail') - Nothing -> Failure ["dpib"] - -dplbsat :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom, NumAtom atom, Ord pf) => - pf -> Failing Bool -dplbsat fm = dplb (defcnfs fm :: Set.Set (Set.Set pf)) Set.empty - -dplbtaut :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom, NumAtom atom, Ord pf) => - pf -> Failing Bool -dplbtaut fm = dplbsat((.~.) fm) >>= return . not - --- ------------------------------------------------------------------------- --- Examples. --- ------------------------------------------------------------------------- - -test03 = TestList [TestCase (assertEqual "dplitaut(prime 101)" (Success True) (dplitaut(prime 101 :: Formula (Atom N)))), - TestCase (assertEqual "dplbtaut(prime 101)" (Success True) (dplbtaut(prime 101 :: Formula (Atom N))))] diff --git a/Data/Logic/Harrison/DefCNF.hs b/Data/Logic/Harrison/DefCNF.hs deleted file mode 100644 --- a/Data/Logic/Harrison/DefCNF.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables #-} -module Data.Logic.Harrison.DefCNF - {- ( Atom - , NumAtom(ma, ai) - , defcnfs - , defcnf1 - , defcnf2 - , defcnf3 - ) -} where - -import Data.Logic.Classes.Combine (Combination(..), BinOp(..), (.&.), (.|.), (.<=>.)) -import Data.Logic.Classes.Formula (Formula(atomic)) -import Data.Logic.Classes.Literal (Literal) -import Data.Logic.Classes.Propositional (PropositionalFormula(foldPropositional), overatoms) -import Data.Logic.Harrison.Prop (nenf, simpcnf, cnf) -import Data.Logic.Harrison.PropExamples (N) -import qualified Data.Map as Map -import qualified Data.Set.Extra as Set - --- ========================================================================= --- Definitional CNF. --- --- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) --- ========================================================================= -{- -START_INTERACTIVE;; -cnf <

(q <=> r)>>;; -END_INTERACTIVE;; --} --- ------------------------------------------------------------------------- --- Make a stylized variable and update the index. --- ------------------------------------------------------------------------- - -data Atom a = P a - -class NumAtom atom where - ma :: N -> atom - ai :: atom -> N - -instance NumAtom (Atom N) where - ma = P - ai (P n) = n - -mkprop :: forall pf atom. (PropositionalFormula pf atom, NumAtom atom) => N -> (pf, N) -mkprop n = (atomic (ma n :: atom), n + 1) - --- ------------------------------------------------------------------------- --- Core definitional CNF procedure. --- ------------------------------------------------------------------------- - -maincnf :: (NumAtom atom, PropositionalFormula pf atom) => (pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int) -maincnf trip@(fm, _defs, _n) = - foldPropositional co tf at fm - where - co (BinOp p (:&:) q) = defstep (.&.) (p,q) trip - co (BinOp p (:|:) q) = defstep (.|.) (p,q) trip - co (BinOp p (:<=>:) q) = defstep (.<=>.) (p,q) trip - co (BinOp _ (:=>:) _) = trip - co ((:~:) _) = trip - tf _ = trip - at _ = trip - -defstep :: (PropositionalFormula pf atom, NumAtom atom, Ord pf) => (pf -> pf -> pf) -> (pf, pf) -> (pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int) -defstep op (p,q) (_fm, defs, n) = - let (fm1,defs1,n1) = maincnf (p,defs,n) in - let (fm2,defs2,n2) = maincnf (q,defs1,n1) in - let fm' = op fm1 fm2 in - case Map.lookup fm' defs2 of - Just _ -> (fm', defs2, n2) - Nothing -> let (v,n3) = mkprop n2 in (v, Map.insert v (v .<=>. fm') defs2,n3) - --- ------------------------------------------------------------------------- --- Make n large enough that "v_m" won't clash with s for any m >= n --- ------------------------------------------------------------------------- - -max_varindex :: NumAtom atom => atom -> Int -> Int -max_varindex atom n = max n (ai atom) - --- ------------------------------------------------------------------------- --- Overall definitional CNF. --- ------------------------------------------------------------------------- - -mk_defcnf :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, NumAtom atom, Ord lit) => - ((pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int)) -> pf -> Set.Set (Set.Set lit) -mk_defcnf fn fm = - let fm' = nenf fm in - let n = 1 + overatoms max_varindex fm' 0 in - let (fm'',defs,_) = fn (fm',Map.empty,n) in - let (deflist {- :: [pf]-}) = Map.elems defs in - Set.unions (simpcnf fm'' : map simpcnf deflist) - -defcnf1 :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, NumAtom atom, Ord lit) => lit -> atom -> pf -> pf -defcnf1 _ _ fm = cnf (mk_defcnf maincnf fm :: Set.Set (Set.Set lit)) - - --- ------------------------------------------------------------------------- --- Example. --- ------------------------------------------------------------------------- -{- -START_INTERACTIVE;; -defcnf1 <<(p \/ (q /\ ~r)) /\ s>>;; -END_INTERACTIVE;; --} --- ------------------------------------------------------------------------- --- Version tweaked to exploit initial structure. --- ------------------------------------------------------------------------- - -subcnf :: (PropositionalFormula pf atom, NumAtom atom) => - ((pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int)) - -> (pf -> pf -> pf) - -> pf - -> pf - -> (pf, Map.Map pf pf, Int) - -> (pf, Map.Map pf pf, Int) -subcnf sfn op p q (_fm,defs,n) = - let (fm1,defs1,n1) = sfn (p,defs,n) in - let (fm2,defs2,n2) = sfn (q,defs1,n1) in - (op fm1 fm2, defs2, n2) - -orcnf :: (NumAtom atom, PropositionalFormula pf atom) => (pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int) -orcnf trip@(fm,_defs,_n) = - foldPropositional co (\ _ -> maincnf trip) (\ _ -> maincnf trip) fm - where - co (BinOp p (:|:) q) = subcnf orcnf (.|.) p q trip - co _ = maincnf trip - -andcnf :: (PropositionalFormula pf atom, NumAtom atom, Ord pf) => (pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int) -andcnf trip@(fm,_defs,_n) = - foldPropositional co (\ _ -> orcnf trip) (\ _ -> orcnf trip) fm - where - co (BinOp p (:&:) q) = subcnf andcnf (.&.) p q trip - co _ = orcnf trip - -defcnfs :: (PropositionalFormula pf atom, Literal lit atom, NumAtom atom, Ord lit) => pf -> Set.Set (Set.Set lit) -defcnfs fm = mk_defcnf andcnf fm - -defcnf2 :: forall pf lit atom.(PropositionalFormula pf atom, Literal lit atom, NumAtom atom, Ord lit) => lit -> atom -> pf -> pf -defcnf2 _ _ fm = cnf (defcnfs fm :: Set.Set (Set.Set lit)) - --- ------------------------------------------------------------------------- --- Examples. --- ------------------------------------------------------------------------- -{- -START_INTERACTIVE;; -defcnf <<(p \/ (q /\ ~r)) /\ s>>;; -END_INTERACTIVE;; --} --- ------------------------------------------------------------------------- --- Version that guarantees 3-CNF. --- ------------------------------------------------------------------------- - -andcnf3 :: (PropositionalFormula pf atom, NumAtom atom, Ord pf) => (pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int) -andcnf3 trip@(fm,_defs,_n) = - foldPropositional co (\ _ -> maincnf trip) (\ _ -> maincnf trip) fm - where - co (BinOp p (:&:) q) = subcnf andcnf3 (.&.) p q trip - co _ = maincnf trip - -defcnf3 :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, NumAtom atom, Ord lit) => lit -> atom -> pf -> pf -defcnf3 _ _ fm = cnf (mk_defcnf andcnf3 fm :: Set.Set (Set.Set lit)) diff --git a/Data/Logic/Harrison/Equal.hs b/Data/Logic/Harrison/Equal.hs deleted file mode 100644 --- a/Data/Logic/Harrison/Equal.hs +++ /dev/null @@ -1,331 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables, TypeSynonymInstances #-} -{-# OPTIONS_GHC -Wall #-} -module Data.Logic.Harrison.Equal -{- ( function_congruence - , equalitize - ) -} where - --- ========================================================================= --- First order logic with equality. --- --- Copyright (co) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) --- ========================================================================= - -import Data.Logic.Classes.Arity (Arity(..)) -import Data.Logic.Classes.Combine ((∧), (⇒)) -import Data.Logic.Classes.Constants (Constants(fromBool)) -import Data.Logic.Classes.Equals (AtomEq(..), applyEq, (.=.), PredicateName(..), funcsAtomEq) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), (∀)) -import Data.Logic.Classes.Formula (Formula(atomic, foldAtoms)) -import Data.Logic.Classes.Term (Term(..)) -import Data.Logic.Harrison.Formulas.FirstOrder (atom_union) -import Data.Logic.Harrison.Lib ((∅)) --- import Data.Logic.Harrison.Skolem (functions) -import qualified Data.Set as Set -import Data.String (IsString(fromString)) - --- is_eq :: (FirstOrderFormula fof atom v, AtomEq atom p term) => fof -> Bool --- is_eq = foldFirstOrder (\ _ _ _ -> False) (\ _ -> False) (\ _ -> False) (foldAtomEq (\ _ _ -> False) (\ _ -> False) (\ _ _ -> True)) --- --- mk_eq :: (FirstOrderFormula fof atom v, AtomEq atom p term) => term -> term -> fof --- mk_eq = (.=.) --- --- dest_eq :: (FirstOrderFormula fof atom v, AtomEq atom p term) => fof -> Failing (term, term) --- dest_eq fm = --- foldFirstOrder (\ _ _ _ -> err) (\ _ -> err) (\ _ -> err) at fm --- where --- at = foldAtomEq (\ _ _ -> err) (\ _ -> err) (\ s t -> Success (s, t)) --- err = Failure ["dest_eq: not an equation"] --- --- lhs :: (FirstOrderFormula fof atom v, AtomEq atom p term) => fof -> Failing term --- lhs eq = dest_eq eq >>= return . fst --- rhs :: (FirstOrderFormula fof atom v, AtomEq atom p term) => fof -> Failing term --- rhs eq = dest_eq eq >>= return . snd - --- ------------------------------------------------------------------------- --- The set of predicates in a formula. --- ------------------------------------------------------------------------- - -predicates :: forall formula atom term v p. (FirstOrderFormula formula atom v, AtomEq atom p term, Ord p) => formula -> Set.Set (PredicateName p) -predicates fm = - atom_union pair fm - where -- pair :: atom -> Set.Set (p, Int) - pair = foldAtomEq (\ p a -> Set.singleton (Named p (maybe (length a) - (\ n -> if n /= length a then n else error "arity mismatch") - (arity p)))) - (\ x -> Set.singleton (Named (fromBool x) 0)) - (\ _ _ -> Set.singleton Equals) - -{- --- | Traverse a formula and pass all (predicates, arity) pairs to a function. --- To collect -foldPredicates :: forall formula atom term v p r. (FirstOrderFormula formula atom v, AtomEq atom p term, Ord p) => - (PredicateName p -> Maybe Int -> r -> r) -> formula -> r -> r -foldPredicates f fm acc = - foldFirstOrder qu co tf at fm - where - fold = foldPredicates f - qu _ _ p = fold p acc - co (BinOp l _ r) = fold r (fold l acc) - co ((:~:) p) = fold p acc - tf x = fold (fromBool x) acc - at = foldAtomEq ap tf eq - ap p _ = f (Name p) (arity p) acc - eq _ _ = f Equals (Just 2) acc --} - --- ------------------------------------------------------------------------- --- Code to generate equality axioms for functions. --- ------------------------------------------------------------------------- - -function_congruence :: forall fof atom term v p f. (FirstOrderFormula fof atom v, AtomEq atom p term, Term term v f) => - (f, Int) -> Set.Set fof -function_congruence (_,0) = (∅) -function_congruence (f,n) = - Set.singleton (foldr (∀) (ant ⇒ con) (argnames_x ++ argnames_y)) - where - argnames_x :: [v] - argnames_x = map (\ m -> fromString ("x" ++ show m)) [1..n] - argnames_y :: [v] - argnames_y = map (\ m -> fromString ("y" ++ show m)) [1..n] - args_x = map vt argnames_x - args_y = map vt argnames_y - ant = foldr1 (∧) (map (uncurry (.=.)) (zip args_x args_y)) - con = fApp f args_x .=. fApp f args_y - --- ------------------------------------------------------------------------- --- And for predicates. --- ------------------------------------------------------------------------- - -predicate_congruence :: (FirstOrderFormula fof atom v, AtomEq atom p term, Term term v f, Ord p) => - PredicateName p -> Set.Set fof -predicate_congruence Equals = Set.empty -predicate_congruence (Named _ 0) = Set.empty -predicate_congruence (Named p n) = - Set.singleton (foldr (∀) (ant ⇒ con) (argnames_x ++ argnames_y)) - where - argnames_x = map (\ m -> fromString ("x" ++ show m)) [1..n] - argnames_y = map (\ m -> fromString ("y" ++ show m)) [1..n] - args_x = map vt argnames_x - args_y = map vt argnames_y - ant = foldr1 (∧) (map (uncurry (.=.)) (zip args_x args_y)) - con = atomic (applyEq p args_x) ⇒ atomic (applyEq p args_y) - --- ------------------------------------------------------------------------- --- Hence implement logic with equality just by adding equality "axioms". --- ------------------------------------------------------------------------- - -equivalence_axioms :: forall fof atom term v p f. (FirstOrderFormula fof atom v, AtomEq atom p term, Term term v f, Ord fof) => Set.Set fof -equivalence_axioms = - Set.fromList - [(∀) "x" (x .=. x), - (∀) "x" ((∀) "y" ((∀) "z" (x .=. y ∧ x .=. z ⇒ y .=. z)))] - where - x :: term - x = vt (fromString "x") - y :: term - y = vt (fromString "y") - z :: term - z = vt (fromString "z") - -equalitize :: forall formula atom term v p f. (FirstOrderFormula formula atom v, Formula formula atom, AtomEq atom p term, Ord p, Show p, Term term v f, Ord formula, Ord f) => - formula -> formula -equalitize fm = - if not (Set.member Equals allpreds) - then fm - else foldr1 (∧) (Set.toList axioms) ⇒ fm - where - axioms = Set.fold (Set.union . function_congruence) (Set.fold (Set.union . predicate_congruence) equivalence_axioms preds) (functions' funcsAtomEq' fm) - funcsAtomEq' :: atom -> Set.Set (f, Int) - funcsAtomEq' = funcsAtomEq - allpreds = predicates fm - preds = Set.delete Equals allpreds - -functions' :: forall formula atom f. (Formula formula atom, Ord f) => (atom -> Set.Set (f, Int)) -> formula -> Set.Set (f, Int) -functions' fa fm = foldAtoms (\ s a -> Set.union s (fa a)) Set.empty fm - --- ------------------------------------------------------------------------- --- Other variants not mentioned in book. --- ------------------------------------------------------------------------- - -{- -{- ************ - -(meson ** equalitize) - <<(forall x y z. x * (y * z) = (x * y) * z) /\ - (forall x. 1 * x = x) /\ - (forall x. x * 1 = x) /\ - (forall x. x * x = 1) - ==> forall x y. x * y = y * x>>;; - --- ------------------------------------------------------------------------- --- With symmetry at leaves and one-sided congruences (Size = 16, 54659 s). --- ------------------------------------------------------------------------- - -let fm = - <<(forall x. x = x) /\ - (forall x y z. x * (y * z) = (x * y) * z) /\ - (forall x y z. =((x * y) * z,x * (y * z))) /\ - (forall x. 1 * x = x) /\ - (forall x. x = 1 * x) /\ - (forall x. i(x) * x = 1) /\ - (forall x. 1 = i(x) * x) /\ - (forall x y. x = y ==> i(x) = i(y)) /\ - (forall x y z. x = y ==> x * z = y * z) /\ - (forall x y z. x = y ==> z * x = z * y) /\ - (forall x y z. x = y /\ y = z ==> x = z) - ==> forall x. x * i(x) = 1>>;; - -time meson fm;; - --- ------------------------------------------------------------------------- --- Newer version of stratified equalities. --- ------------------------------------------------------------------------- - -let fm = - <<(forall x y z. axiom(x * (y * z),(x * y) * z)) /\ - (forall x y z. axiom((x * y) * z,x * (y * z)) /\ - (forall x. axiom(1 * x,x)) /\ - (forall x. axiom(x,1 * x)) /\ - (forall x. axiom(i(x) * x,1)) /\ - (forall x. axiom(1,i(x) * x)) /\ - (forall x x'. x = x' ==> cchain(i(x),i(x'))) /\ - (forall x x' y y'. x = x' /\ y = y' ==> cchain(x * y,x' * y'))) /\ - (forall s t. axiom(s,t) ==> achain(s,t)) /\ - (forall s t u. axiom(s,t) /\ (t = u) ==> achain(s,u)) /\ - (forall x x' u. x = x' /\ achain(i(x'),u) ==> cchain(i(x),u)) /\ - (forall x x' y y' u. - x = x' /\ y = y' /\ achain(x' * y',u) ==> cchain(x * y,u)) /\ - (forall s t. cchain(s,t) ==> s = t) /\ - (forall s t. achain(s,t) ==> s = t) /\ - (forall t. t = t) - ==> forall x. x * i(x) = 1>>;; - -time meson fm;; - -let fm = - <<(forall x y z. axiom(x * (y * z),(x * y) * z)) /\ - (forall x y z. axiom((x * y) * z,x * (y * z)) /\ - (forall x. axiom(1 * x,x)) /\ - (forall x. axiom(x,1 * x)) /\ - (forall x. axiom(i(x) * x,1)) /\ - (forall x. axiom(1,i(x) * x)) /\ - (forall x x'. x = x' ==> cong(i(x),i(x'))) /\ - (forall x x' y y'. x = x' /\ y = y' ==> cong(x * y,x' * y'))) /\ - (forall s t. axiom(s,t) ==> achain(s,t)) /\ - (forall s t. cong(s,t) ==> cchain(s,t)) /\ - (forall s t u. axiom(s,t) /\ (t = u) ==> achain(s,u)) /\ - (forall s t u. cong(s,t) /\ achain(t,u) ==> cchain(s,u)) /\ - (forall s t. cchain(s,t) ==> s = t) /\ - (forall s t. achain(s,t) ==> s = t) /\ - (forall t. t = t) - ==> forall x. x * i(x) = 1>>;; - -time meson fm;; - --- ------------------------------------------------------------------------- --- Showing congruence closure. --- ------------------------------------------------------------------------- - -let fm = equalitize - < f(c) = c>>;; - -time meson fm;; - -let fm = - < achain(s,t)) /\ - (forall s t. cong(s,t) ==> cchain(s,t)) /\ - (forall s t u. axiom(s,t) /\ (t = u) ==> achain(s,u)) /\ - (forall s t u. cong(s,t) /\ achain(t,u) ==> cchain(s,u)) /\ - (forall s t. cchain(s,t) ==> s = t) /\ - (forall s t. achain(s,t) ==> s = t) /\ - (forall t. t = t) /\ - (forall x y. x = y ==> cong(f(x),f(y))) - ==> f(c) = c>>;; - -time meson fm;; - --- ------------------------------------------------------------------------- --- With stratified equalities. --- ------------------------------------------------------------------------- - -let fm = - <<(forall x y z. eqA (x * (y * z),(x * y) * z)) /\ - (forall x y z. eqA ((x * y) * z)) /\ - (forall x. eqA (1 * x,x)) /\ - (forall x. eqA (x,1 * x)) /\ - (forall x. eqA (i(x) * x,1)) /\ - (forall x. eqA (1,i(x) * x)) /\ - (forall x. eqA (x,x)) /\ - (forall x y. eqA (x,y) ==> eqC (i(x),i(y))) /\ - (forall x y. eqC (x,y) ==> eqC (i(x),i(y))) /\ - (forall x y. eqT (x,y) ==> eqC (i(x),i(y))) /\ - (forall w x y z. eqA (w,x) /\ eqA (y,z) ==> eqC (w * y,x * z)) /\ - (forall w x y z. eqA (w,x) /\ eqC (y,z) ==> eqC (w * y,x * z)) /\ - (forall w x y z. eqA (w,x) /\ eqT (y,z) ==> eqC (w * y,x * z)) /\ - (forall w x y z. eqC (w,x) /\ eqA (y,z) ==> eqC (w * y,x * z)) /\ - (forall w x y z. eqC (w,x) /\ eqC (y,z) ==> eqC (w * y,x * z)) /\ - (forall w x y z. eqC (w,x) /\ eqT (y,z) ==> eqC (w * y,x * z)) /\ - (forall w x y z. eqT (w,x) /\ eqA (y,z) ==> eqC (w * y,x * z)) /\ - (forall w x y z. eqT (w,x) /\ eqC (y,z) ==> eqC (w * y,x * z)) /\ - (forall w x y z. eqT (w,x) /\ eqT (y,z) ==> eqC (w * y,x * z)) /\ - (forall x y z. eqA (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\ - (forall x y z. eqC (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\ - (forall x y z. eqA (x,y) /\ eqC (y,z) ==> eqT (x,z)) /\ - (forall x y z. eqA (x,y) /\ eqT (y,z) ==> eqT (x,z)) /\ - (forall x y z. eqC (x,y) /\ eqT (y,z) ==> eqT (x,z)) - ==> forall x. eqT (x * i(x),1)>>;; - --- ------------------------------------------------------------------------- --- With transitivity chains... --- ------------------------------------------------------------------------- - -let fm = - <<(forall x y z. eqA (x * (y * z),(x * y) * z)) /\ - (forall x y z. eqA ((x * y) * z)) /\ - (forall x. eqA (1 * x,x)) /\ - (forall x. eqA (x,1 * x)) /\ - (forall x. eqA (i(x) * x,1)) /\ - (forall x. eqA (1,i(x) * x)) /\ - (forall x y. eqA (x,y) ==> eqC (i(x),i(y))) /\ - (forall x y. eqC (x,y) ==> eqC (i(x),i(y))) /\ - (forall w x y. eqA (w,x) ==> eqC (w * y,x * y)) /\ - (forall w x y. eqC (w,x) ==> eqC (w * y,x * y)) /\ - (forall x y z. eqA (y,z) ==> eqC (x * y,x * z)) /\ - (forall x y z. eqC (y,z) ==> eqC (x * y,x * z)) /\ - (forall x y z. eqA (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\ - (forall x y z. eqC (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\ - (forall x y z. eqA (x,y) /\ eqC (y,z) ==> eqT (x,z)) /\ - (forall x y z. eqC (x,y) /\ eqC (y,z) ==> eqT (x,z)) /\ - (forall x y z. eqA (x,y) /\ eqT (y,z) ==> eqT (x,z)) /\ - (forall x y z. eqC (x,y) /\ eqT (y,z) ==> eqT (x,z)) - ==> forall x. eqT (x * i(x),1) \/ eqC (x * i(x),1)>>;; - -time meson fm;; - --- ------------------------------------------------------------------------- --- Enforce canonicity (proof size = 20). --- ------------------------------------------------------------------------- - -let fm = - <<(forall x y z. eq1(x * (y * z),(x * y) * z)) /\ - (forall x y z. eq1((x * y) * z,x * (y * z))) /\ - (forall x. eq1(1 * x,x)) /\ - (forall x. eq1(x,1 * x)) /\ - (forall x. eq1(i(x) * x,1)) /\ - (forall x. eq1(1,i(x) * x)) /\ - (forall x y z. eq1(x,y) ==> eq1(x * z,y * z)) /\ - (forall x y z. eq1(x,y) ==> eq1(z * x,z * y)) /\ - (forall x y z. eq1(x,y) /\ eq2(y,z) ==> eq2(x,z)) /\ - (forall x y. eq1(x,y) ==> eq2(x,y)) - ==> forall x. eq2(x,i(x))>>;; - -time meson fm;; - -***************** -} -END_INTERACTIVE;; --} diff --git a/Data/Logic/Harrison/FOL.hs b/Data/Logic/Harrison/FOL.hs deleted file mode 100644 --- a/Data/Logic/Harrison/FOL.hs +++ /dev/null @@ -1,306 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeSynonymInstances #-} -{-# OPTIONS_GHC -Wall #-} -module Data.Logic.Harrison.FOL - ( eval - , list_disj - , list_conj - , var - , fv - -- , fv' - , subst - -- , subst' - , generalize - ) where - -import Data.Logic.Classes.Apply (Apply(..), apply) -import Data.Logic.Classes.Atom (Atom(allVariables, substitute)) -import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..), binop) -import Data.Logic.Classes.Constants (Constants (fromBool), true, false) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), quant) -import Data.Logic.Classes.Formula (Formula(atomic)) -import Data.Logic.Classes.Negate ((.~.)) -import Data.Logic.Classes.Propositional (PropositionalFormula(..)) -import Data.Logic.Classes.Term (Term(vt), fvt) -import Data.Logic.Classes.Variable (Variable(..)) -import Data.Logic.Harrison.Formulas.FirstOrder (on_atoms) -import Data.Logic.Harrison.Lib ((|->), setAny) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import qualified Data.Set as Set -import Prelude hiding (pred) - --- ========================================================================= --- Basic stuff for first order logic. --- --- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) --- ========================================================================= - --- ------------------------------------------------------------------------- --- Interpretation of formulas. --- ------------------------------------------------------------------------- - -eval :: FirstOrderFormula formula atom v => formula -> (atom -> Bool) -> Bool -eval fm v = - foldFirstOrder qu co id at fm - where - qu _ _ p = eval p v - co ((:~:) p) = not (eval p v) - co (BinOp p (:&:) q) = eval p v && eval q v - co (BinOp p (:|:) q) = eval p v || eval q v - co (BinOp p (:=>:) q) = not (eval p v) || eval q v - co (BinOp p (:<=>:) q) = eval p v == eval q v - at = v - -list_conj :: (Constants formula, Combinable formula) => Set.Set formula -> formula -list_conj l = maybe true (\ (x, xs) -> Set.fold (.&.) x xs) (Set.minView l) - -list_disj :: (Constants formula, Combinable formula) => Set.Set formula -> formula -list_disj l = maybe false (\ (x, xs) -> Set.fold (.|.) x xs) (Set.minView l) - -mkLits :: (FirstOrderFormula formula atom v, Ord formula) => - Set.Set formula -> (atom -> Bool) -> formula -mkLits pvs v = list_conj (Set.map (\ p -> if eval p v then p else (.~.) p) pvs) - --- ------------------------------------------------------------------------- --- Special case of applying a subfunction to the top *terms*. --- ------------------------------------------------------------------------- - -on_formula :: forall fol atom term v p. (FirstOrderFormula fol atom v, Apply atom p term) => (term -> term) -> fol -> fol -on_formula f = on_atoms (foldApply (\ p ts -> atomic (apply p (map f ts) :: atom)) fromBool) - --- ------------------------------------------------------------------------- --- Parsing of terms. --- ------------------------------------------------------------------------- - -{- -let is_const_name s = forall numeric (explode s) or s = "nil";; - -let rec parse_atomic_term vs inp = - match inp with - [] -> failwith "term expected" - | "("::rest -> parse_bracketed (parse_term vs) ")" rest - | "-"::rest -> papply (fun t -> Fn("-",[t])) (parse_atomic_term vs rest) - | f::"("::")"::rest -> Fn(f,[]),rest - | f::"("::rest -> - papply (fun args -> Fn(f,args)) - (parse_bracketed (parse_list "," (parse_term vs)) ")" rest) - | a::rest -> - (if is_const_name a & not(mem a vs) then Fn(a,[]) else Var a),rest - -and parse_term vs inp = - parse_right_infix "::" (fun (e1,e2) -> Fn("::",[e1;e2])) - (parse_right_infix "+" (fun (e1,e2) -> Fn("+",[e1;e2])) - (parse_left_infix "-" (fun (e1,e2) -> Fn("-",[e1;e2])) - (parse_right_infix "*" (fun (e1,e2) -> Fn("*",[e1;e2])) - (parse_left_infix "/" (fun (e1,e2) -> Fn("/",[e1;e2])) - (parse_left_infix "^" (fun (e1,e2) -> Fn("^",[e1;e2])) - (parse_atomic_term vs)))))) inp;; - -let parset = make_parser (parse_term []);; - --- ------------------------------------------------------------------------- --- Parsing of formulas. --- ------------------------------------------------------------------------- - -let parse_infix_atom vs inp = - let tm,rest = parse_term vs inp in - if exists (nextin rest) ["="; "<"; "<="; ">"; ">="] then - papply (fun tm' -> Atom(R(hd rest,[tm;tm']))) - (parse_term vs (tl rest)) - else failwith "";; - -let parse_atom vs inp = - try parse_infix_atom vs inp with Failure _ -> - match inp with - | p::"("::")"::rest -> Atom(R(p,[])),rest - | p::"("::rest -> - papply (fun args -> Atom(R(p,args))) - (parse_bracketed (parse_list "," (parse_term vs)) ")" rest) - | p::rest when p <> "(" -> Atom(R(p,[])),rest - | _ -> failwith "parse_atom";; - -let parse = make_parser - (parse_formula (parse_infix_atom,parse_atom) []);; - --- ------------------------------------------------------------------------- --- Set up parsing of quotations. --- ------------------------------------------------------------------------- - -let default_parser = parse;; - -let secondary_parser = parset;; --} - --- ------------------------------------------------------------------------- --- Printing of terms. --- ------------------------------------------------------------------------- -{- -let rec print_term prec fm = - match fm with - Var x -> print_string x - | Fn("^",[tm1;tm2]) -> print_infix_term true prec 24 "^" tm1 tm2 - | Fn("/",[tm1;tm2]) -> print_infix_term true prec 22 " /" tm1 tm2 - | Fn("*",[tm1;tm2]) -> print_infix_term false prec 20 " *" tm1 tm2 - | Fn("-",[tm1;tm2]) -> print_infix_term true prec 18 " -" tm1 tm2 - | Fn("+",[tm1;tm2]) -> print_infix_term false prec 16 " +" tm1 tm2 - | Fn("::",[tm1;tm2]) -> print_infix_term false prec 14 "::" tm1 tm2 - | Fn(f,args) -> print_fargs f args - -and print_fargs f args = - print_string f; - if args = [] then () else - (print_string "("; - open_box 0; - print_term 0 (hd args); print_break 0 0; - do_list (fun t -> print_string ","; print_break 0 0; print_term 0 t) - (tl args); - close_box(); - print_string ")") - -and print_infix_term isleft oldprec newprec sym p q = - if oldprec > newprec then (print_string "("; open_box 0) else (); - print_term (if isleft then newprec else newprec+1) p; - print_string sym; - print_break (if String.sub sym 0 1 = " " then 1 else 0) 0; - print_term (if isleft then newprec+1 else newprec) q; - if oldprec > newprec then (close_box(); print_string ")") else ();; - -let printert tm = - open_box 0; print_string "<<|"; - open_box 0; print_term 0 tm; close_box(); - print_string "|>>"; close_box();; - -#install_printer printert;; - --- ------------------------------------------------------------------------- --- Printing of formulas. --- ------------------------------------------------------------------------- - -let print_atom prec (R(p,args)) = - if mem p ["="; "<"; "<="; ">"; ">="] & length args = 2 - then print_infix_term false 12 12 (" "^p) (el 0 args) (el 1 args) - else print_fargs p args;; - -let print_fol_formula = print_qformula print_atom;; - -#install_printer print_fol_formula;; - --- ------------------------------------------------------------------------- --- Examples in the main text. --- ------------------------------------------------------------------------- - -START_INTERACTIVE;; -<>;; - -<<~(forall x. P(x)) <=> exists y. ~P(y)>>;; -END_INTERACTIVE;; --} - --- ------------------------------------------------------------------------- --- Free variables in terms and formulas. --- ------------------------------------------------------------------------- - --- | Return all variables occurring in a formula. -var :: forall formula atom term v. - (FirstOrderFormula formula atom v, - Atom atom term v) => formula -> Set.Set v -var fm = - foldFirstOrder qu co tf at fm - where - qu _ x p = Set.insert x (var p) - co ((:~:) p) = var p - co (BinOp p _ q) = Set.union (var p) (var q) - tf _ = Set.empty - at :: atom -> Set.Set v - at = allVariables - --- | Return the variables that occur free in a formula. -fv :: forall formula atom term v. - (FirstOrderFormula formula atom v, - Atom atom term v) => formula -> Set.Set v -fv fm = - foldFirstOrder qu co tf at fm - where - qu _ x p = Set.delete x (fv p) - co ((:~:) p) = fv p - co (BinOp p _ q) = Set.union (fv p) (fv q) - tf _ = Set.empty - at = allVariables - --- | Return the variables in a propositional formula. -fv' :: forall formula atom term v. (PropositionalFormula formula atom, Atom atom term v, Ord v) => formula -> Set.Set v -fv' fm = - foldPropositional co tf allVariables fm - where - co ((:~:) p) = fv' p - co (BinOp p _ q) = Set.union (fv' p) (fv' q) - tf _ = Set.empty - --- ------------------------------------------------------------------------- --- Universal closure of a formula. --- ------------------------------------------------------------------------- - -generalize :: (FirstOrderFormula formula atom v, Atom atom term v) => formula -> formula -generalize fm = Set.fold for_all fm (fv fm) - --- ------------------------------------------------------------------------- --- Substitution in formulas, with variable renaming. --- ------------------------------------------------------------------------- - -subst :: (FirstOrderFormula formula atom v, - Term term v f, - Atom atom term v) => - Map.Map v term -> formula -> formula -subst env fm = - foldFirstOrder qu co tf at fm - where - qu op x p = quant op x' (subst ((x |-> vt x') env) p) - where - x' = if setAny (\ y -> Set.member x (fvt (fromMaybe (vt y) (Map.lookup y env)))) (Set.delete x (fv p)) - then variant x (fv (subst (Map.delete x env) p)) - else x - co ((:~:) p) = ((.~.) (subst env p)) - co (BinOp p op q) = binop (subst env p) op (subst env q) - tf = fromBool - at = atomic . substitute env - -subst' :: (PropositionalFormula formula atom, - -- Formula formula term v, - Atom atom term v, - Term term v f) => - Map.Map v term -> formula -> formula -subst' env fm = - foldPropositional co tf at fm - where - co ((:~:) p) = ((.~.) (subst' env p)) - co (BinOp p op q) = binop (subst' env p) op (subst' env q) - tf = fromBool - at = atomic . substitute env - -{- --- |Replace each free occurrence of variable old with term new. -substitute :: forall formula atom term v f. (FirstOrderFormula formula atom v, Term term v f) => v -> term -> (atom -> formula) -> formula -> formula -substitute old new atom formula = - foldTerm (\ new' -> if old == new' then formula else substitute' formula) - (\ _ _ -> substitute' formula) - new - where - substitute' = - foldFirstOrder -- If the old variable appears in a quantifier - -- we can stop doing the substitution. - (\ q v f' -> quant q v (if old == v then f' else substitute' f')) - (\ cm -> case cm of - ((:~:) f') -> combine ((:~:) (substitute' f')) - (BinOp f1 op f2) -> combine (BinOp (substitute' f1) op (substitute' f2))) - fromBool - atom --} -{- - substitute old new atom formula - where - atom = foldAtomEq (\ p ts -> pApp p (map st ts)) fromBool (\ t1 t2 -> st t1 .=. st t2) - st :: term -> term - st t = foldTerm sv (\ func ts -> fApp func (map st ts)) t - sv v = if v == old then new else vt v --} - diff --git a/Data/Logic/Harrison/Formulas/FirstOrder.hs b/Data/Logic/Harrison/Formulas/FirstOrder.hs --- a/Data/Logic/Harrison/Formulas/FirstOrder.hs +++ b/Data/Logic/Harrison/Formulas/FirstOrder.hs @@ -8,10 +8,11 @@ , atom_union ) where +import Data.Logic.ATP.Formulas (IsFormula(AtomOf)) +import Data.Logic.ATP.Lit ((.~.)) +import Data.Logic.ATP.Prop (BinOp(..), binop) +import Data.Logic.ATP.Quantified (IsQuantified(..), quant) import qualified Data.Set as Set -import Data.Logic.Classes.Combine (Combination(..), BinOp(..), binop) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), quant) -import Data.Logic.Classes.Negate ((.~.)) -- ------------------------------------------------------------------------- -- General parsing of iterated infixes. @@ -159,33 +160,33 @@ match fm with Imp(p,q) -> (p,q) | _ -> failwith "dest_imp";; -} -antecedent :: FirstOrderFormula formula atom v => formula -> formula +antecedent :: IsQuantified formula => formula -> formula antecedent formula = - foldFirstOrder (\ _ _ _ -> err) c (\ _ -> err) (\ _ -> err) formula + foldQuantified (\ _ _ _ -> err) c (\ _ -> err) (\ _ -> err) (\ _ -> err) formula where - c (BinOp p (:=>:) _) = p - c _ = err + c p (:=>:) _ = p + c _ _ _ = err err = error "antecedent" -consequent :: FirstOrderFormula formula atom v => formula -> formula +consequent :: IsQuantified formula => formula -> formula consequent formula = - foldFirstOrder (\ _ _ _ -> err) c (\ _ -> err) (\ _ -> err) formula + foldQuantified (\ _ _ _ -> err) c (\ _ -> err) (\ _ -> err) (\ _ -> err) formula where - c (BinOp _ (:=>:) q) = q - c _ = err + c _ (:=>:) q = q + c _ _ _ = err err = error "consequent" -- ------------------------------------------------------------------------- -- Apply a function to the atoms, otherwise keeping structure. -- ------------------------------------------------------------------------- -on_atoms :: forall formula atom v. FirstOrderFormula formula atom v => (atom -> formula) -> formula -> formula +on_atoms :: forall formula. IsQuantified formula => (AtomOf formula -> formula) -> formula -> formula on_atoms f fm = - foldFirstOrder qu co tf at fm - where + foldQuantified qu co ne tf at fm + where qu op v fm' = quant op v (on_atoms f fm') - co ((:~:) fm') = (.~.) (on_atoms f fm') - co (BinOp f1 op f2) = binop (on_atoms f f1) op (on_atoms f f2) + ne fm' = (.~.) (on_atoms f fm') + co f1 op f2 = binop (on_atoms f f1) op (on_atoms f f2) tf _ = fm at = f @@ -193,13 +194,13 @@ -- Formula analog of list iterator "itlist". -- ------------------------------------------------------------------------- -over_atoms :: FirstOrderFormula formula atom v => (atom -> b -> b) -> formula -> b -> b +over_atoms :: IsQuantified formula => (AtomOf formula -> b -> b) -> formula -> b -> b over_atoms f fm b = - foldFirstOrder qu co tf pr fm + foldQuantified qu co ne tf pr fm where qu _ _ p = over_atoms f p b - co ((:~:) p) = over_atoms f p b - co (BinOp p _ q) = over_atoms f p (over_atoms f q b) + ne p = over_atoms f p b + co p _ q = over_atoms f p (over_atoms f q b) tf _ = b pr atom = f atom b @@ -207,5 +208,5 @@ -- Special case of a union of the results of a function over the atoms. -- ------------------------------------------------------------------------- -atom_union :: (FirstOrderFormula formula atom v, Ord b) => (atom -> Set.Set b) -> formula -> Set.Set b +atom_union :: (IsQuantified formula, Ord b) => (AtomOf formula -> Set.Set b) -> formula -> Set.Set b atom_union f fm = over_atoms (\ h t -> Set.union (f h) t) fm Set.empty diff --git a/Data/Logic/Harrison/Formulas/Propositional.hs b/Data/Logic/Harrison/Formulas/Propositional.hs --- a/Data/Logic/Harrison/Formulas/Propositional.hs +++ b/Data/Logic/Harrison/Formulas/Propositional.hs @@ -3,16 +3,9 @@ module Data.Logic.Harrison.Formulas.Propositional ( antecedent , consequent - , on_atoms - , over_atoms - , atom_union ) where -import qualified Data.Set as Set ---import Data.Logic.Classes.Constants (Constants(..)) -import Data.Logic.Classes.Combine (Combination(..), BinOp(..), binop) -import Data.Logic.Classes.Negate ((.~.)) -import Data.Logic.Classes.Propositional (PropositionalFormula(..)) +import Data.Logic.ATP.Prop (BinOp((:=>:)), IsPropositional(..), JustPropositional, foldPropositional) -- ------------------------------------------------------------------------- -- General parsing of iterated infixes. @@ -160,49 +153,16 @@ match fm with Imp(p,q) -> (p,q) | _ -> failwith "dest_imp";; -} -antecedent :: PropositionalFormula formula atomic => formula -> formula +antecedent :: (IsPropositional formula, JustPropositional formula) => formula -> formula antecedent formula = - foldPropositional c (error "antecedent") (error "antecedent") formula + foldPropositional c (error "antecedent") (error "antecedent") (error "antecedent") formula where - c (BinOp p (:=>:) _) = p - c _ = error "antecedent" + c p (:=>:) _ = p + c _ _ _ = error "antecedent" -consequent :: PropositionalFormula formula atomic => formula -> formula +consequent :: (IsPropositional formula, JustPropositional formula) => formula -> formula consequent formula = - foldPropositional c (error "consequent") (error "consequent") formula - where - c (BinOp _ (:=>:) q) = q - c _ = error "consequent" - --- ------------------------------------------------------------------------- --- Apply a function to the atoms, otherwise keeping structure. --- ------------------------------------------------------------------------- - -on_atoms :: PropositionalFormula formula atomic => (atomic -> formula) -> formula -> formula -on_atoms f fm = - foldPropositional co tf at fm - where - co ((:~:) fm') = (.~.) (on_atoms f fm') - co (BinOp f1 op f2) = binop (on_atoms f f1) op (on_atoms f f2) - tf _ = fm - at x = f x - --- ------------------------------------------------------------------------- --- Formula analog of list iterator "itlist". --- ------------------------------------------------------------------------- - -over_atoms :: (PropositionalFormula formula atomic) => (atomic -> b -> b) -> formula -> b -> b -over_atoms f fm b = - foldPropositional co tf at fm + foldPropositional c (error "consequent") (error "consequent") (error "consequent") formula where - co ((:~:) p) = over_atoms f p b - co (BinOp p _ q) = over_atoms f p (over_atoms f q b) - tf _ = b - at x = f x b - --- ------------------------------------------------------------------------- --- Special case of a union of the results of a function over the atoms. --- ------------------------------------------------------------------------- - -atom_union :: (PropositionalFormula formula atomic, Ord b) => (atomic -> Set.Set b) -> formula -> Set.Set b -atom_union f fm = over_atoms (\ h t -> Set.union (f h) t) fm Set.empty + c _ (:=>:) q = q + c _ _ _ = error "consequent" diff --git a/Data/Logic/Harrison/Herbrand.hs b/Data/Logic/Harrison/Herbrand.hs deleted file mode 100644 --- a/Data/Logic/Harrison/Herbrand.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} -module Data.Logic.Harrison.Herbrand where - -import Control.Applicative.Error (Failing(..)) -import Data.Logic.Classes.Atom (Atom(substitute, freeVariables)) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula) -import Data.Logic.Classes.Formula (Formula(..)) -import Data.Logic.Classes.Literal (Literal) -import Data.Logic.Classes.Negate ((.~.)) -import Data.Logic.Classes.Propositional (PropositionalFormula) -import Data.Logic.Classes.Term (Term, fApp) -import Data.Logic.Harrison.DP (dpll) -import Data.Logic.Harrison.FOL (generalize) -import Data.Logic.Harrison.Lib (distrib', allpairs) -import Data.Logic.Harrison.Normal (trivial) -import Data.Logic.Harrison.Prop (eval, simpcnf, simpdnf) -import Data.Logic.Harrison.Skolem (runSkolem, skolemize, functions) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.String (IsString(..)) - --- ========================================================================= --- Relation between FOL and propositonal logic; Herbrand theorem. --- --- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) --- ========================================================================= - --- ------------------------------------------------------------------------- --- Propositional valuation. --- ------------------------------------------------------------------------- - -pholds :: (PropositionalFormula formula atom, Ord atom) => (Map.Map atom Bool) -> formula -> Bool -pholds d fm = eval fm d - --- ------------------------------------------------------------------------- --- Get the constants for Herbrand base, adding nullary one if necessary. --- ------------------------------------------------------------------------- - -herbfuns :: forall pf atom term v f. (PropositionalFormula pf atom, Formula pf atom, Atom atom term v, Term term v f, IsString f, Ord f) => - (atom -> Set.Set (f, Int)) - -> pf - -> (Set.Set (f, Int), Set.Set (f, Int)) -herbfuns fa fm = - let (cns,fns) = Set.partition (\ (_,ar) -> ar == 0) (functions fa fm) in - if Set.null cns then (Set.singleton (fromString "c",0),fns) else (cns,fns) - --- ------------------------------------------------------------------------- --- Enumeration of ground terms and m-tuples, ordered by total fns. --- ------------------------------------------------------------------------- - -groundterms :: forall term v f. (Term term v f) => - Set.Set term -> Set.Set (f, Int) -> Int -> Set.Set term -groundterms cntms _ 0 = cntms -groundterms cntms funcs n = - Set.fold terms Set.empty funcs - where - terms (f,m) l = Set.union (Set.map (fApp f) (groundtuples cntms funcs (n - 1) m)) l - -groundtuples :: forall term v f. (Term term v f) => - Set.Set term -> Set.Set (f, Int) -> Int -> Int -> Set.Set [term] -groundtuples _ _ 0 0 = Set.singleton [] -groundtuples _ _ _ 0 = Set.empty -groundtuples cntms funcs n m = - Set.fold tuples Set.empty (Set.fromList [0 .. n]) - where - tuples k l = Set.union (allpairs (:) (groundterms cntms funcs k) (groundtuples cntms funcs (n - k) (m - 1))) l - --- ------------------------------------------------------------------------- --- Iterate modifier "mfn" over ground terms till "tfn" fails. --- ------------------------------------------------------------------------- - -herbloop :: forall lit atom v term f. (Literal lit atom, Term term v f, Atom atom term v) => - (Set.Set (Set.Set lit) -> (lit -> lit) -> Set.Set (Set.Set lit) -> Set.Set (Set.Set lit)) - -> (Set.Set (Set.Set lit) -> Failing Bool) - -> Set.Set (Set.Set lit) - -> Set.Set term - -> Set.Set (f, Int) - -> [v] - -> Int - -> Set.Set (Set.Set lit) - -> Set.Set [term] - -> Set.Set [term] - -> Failing (Set.Set [term]) -herbloop mfn tfn fl0 cntms funcs fvs n fl tried tuples = -{- - print_string(string_of_int(length tried) ++ " ground instances tried; " ++ - string_of_int(length fl) ++ " items in list") - print_newline(); --} - case Set.minView tuples of - Nothing -> - let newtups = groundtuples cntms funcs n (length fvs) in - herbloop mfn tfn fl0 cntms funcs fvs (n + 1) fl tried newtups - Just (tup, tups) -> - let fpf' = Map.fromList (zip fvs tup) in - let fl' = mfn fl0 (subst' fpf') fl in - case tfn fl' of - Failure msgs -> Failure msgs - Success x -> - if not x - then Success (Set.insert tup tried) - else herbloop mfn tfn fl0 cntms funcs fvs n fl' (Set.insert tup tried) tups - -subst' :: forall lit atom term v f. (Literal lit atom, Atom atom term v, Term term v f) => Map.Map v term -> lit -> lit -subst' env fm = - mapAtoms (atomic . substitute') fm - where substitute' :: atom -> atom - substitute' = substitute env - --- ------------------------------------------------------------------------- --- Hence a simple Gilmore-type procedure. --- ------------------------------------------------------------------------- - -gilmore_loop :: (Literal lit atom, Term term v f, Atom atom term v, Ord lit) => - Set.Set (Set.Set lit) - -> Set.Set term - -> Set.Set (f, Int) - -> [v] - -> Int - -> Set.Set (Set.Set lit) - -> Set.Set [term] - -> Set.Set [term] - -> Failing (Set.Set [term]) -gilmore_loop = - herbloop mfn (Success . not . Set.null) - where - mfn djs0 ifn djs = Set.filter (not . trivial) (distrib' (Set.map (Set.map ifn) djs0) djs) - -gilmore :: forall fof pf atom term v f. - (FirstOrderFormula fof atom v, - PropositionalFormula pf atom, - Literal pf atom, - Term term v f, - Atom atom term v, - IsString f, - Ord pf) => - pf -> (atom -> Set.Set (f, Int)) -> fof -> Failing Int -gilmore _ fa fm = - let sfm = runSkolem (skolemize id ((.~.)(generalize fm))) :: pf in - let fvs = Set.toList (foldAtoms (\ s (a :: atom) -> Set.union s (freeVariables a)) Set.empty sfm) - (consts,funcs) = herbfuns fa sfm in - let cntms = Set.map (\ (c,_) -> fApp c []) consts in - gilmore_loop (simpdnf sfm :: Set.Set (Set.Set pf)) cntms funcs (fvs) 0 Set.empty Set.empty Set.empty >>= return . Set.size - --- ------------------------------------------------------------------------- --- First example and a little tracing. --- ------------------------------------------------------------------------- -{- -test01 = - let fm = exists "x" (for_all "y" (pApp "p" [vt "x"] .=>. pApp "p" [vt "y"])) - sfm = skolemize ((.~.) fm) in - TestList [TestCase (assertEqual "gilmore 1" 2 (gilmore fm))] - -START_INTERACTIVE;; -gilmore < P(y)>>;; - -let sfm = skolemize(Not < P(y)>>);; - --- ------------------------------------------------------------------------- --- Quick example. --- ------------------------------------------------------------------------- - -let p24 = gilmore - <<~(exists x. U(x) /\ Q(x)) /\ - (forall x. P(x) ==> Q(x) \/ R(x)) /\ - ~(exists x. P(x) ==> (exists x. Q(x))) /\ - (forall x. Q(x) /\ R(x) ==> U(x)) - ==> (exists x. P(x) /\ R(x))>>;; - --- ------------------------------------------------------------------------- --- Slightly less easy example. --- ------------------------------------------------------------------------- - -let p45 = gilmore - <<(forall x. P(x) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y)) - ==> (forall y. G(y) /\ H(x,y) ==> R(y))) /\ - ~(exists y. L(y) /\ R(y)) /\ - (exists x. P(x) /\ (forall y. H(x,y) ==> L(y)) /\ - (forall y. G(y) /\ H(x,y) ==> J(x,y))) - ==> (exists x. P(x) /\ ~(exists y. G(y) /\ H(x,y)))>>;; -END_INTERACTIVE;; --} --- ------------------------------------------------------------------------- --- Apparently intractable example. --- ------------------------------------------------------------------------- - -{- - -let p20 = gilmore - <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w)) - ==> (exists x y. P(x) /\ Q(y)) ==> (exists z. R(z))>>;; - --} - - --- ------------------------------------------------------------------------- --- The Davis-Putnam procedure for first order logic. --- ------------------------------------------------------------------------- - -dp_mfn :: (Ord b, Ord a) => - Set.Set (Set.Set a) - -> (a -> b) - -> Set.Set (Set.Set b) - -> Set.Set (Set.Set b) -dp_mfn cjs0 ifn cjs = Set.union (Set.map (Set.map ifn) cjs0) cjs - -dp_loop :: forall lit atom v term f. (Literal lit atom, Term term v f, Atom atom term v, Ord lit) => - Set.Set (Set.Set lit) - -> Set.Set term - -> Set.Set (f, Int) - -> [v] - -> Int - -> Set.Set (Set.Set lit) - -> Set.Set [term] - -> Set.Set [term] - -> Failing (Set.Set [term]) -dp_loop = herbloop dp_mfn dpll - -davisputnam :: forall fof atom term v lit f. - (FirstOrderFormula fof atom v, - PropositionalFormula lit atom, - Literal lit atom, - Term term v f, - Atom atom term v, - IsString f, - Ord lit) => - lit -> (atom -> Set.Set (f, Int)) -> fof -> Failing Int -davisputnam _ fa fm = - let (sfm :: lit) = runSkolem (skolemize id ((.~.)(generalize fm))) in - let fvs = Set.toList (foldAtoms (\ s (a :: atom) -> Set.union (freeVariables a) s) Set.empty sfm) - (consts,funcs) = herbfuns fa sfm in - let cntms = Set.map (\ (c,_) -> fApp c [] :: term) consts in - dp_loop (simpcnf sfm :: Set.Set (Set.Set lit)) cntms funcs fvs 0 Set.empty Set.empty Set.empty >>= return . Set.size - --- ------------------------------------------------------------------------- --- Show how much better than the Gilmore procedure this can be. --- ------------------------------------------------------------------------- - -{- -START_INTERACTIVE;; -let p20 = davisputnam - <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w)) - ==> (exists x y. P(x) /\ Q(y)) ==> (exists z. R(z))>>;; -END_INTERACTIVE;; --} - --- ------------------------------------------------------------------------- --- Try to cut out useless instantiations in final result. --- ------------------------------------------------------------------------- - -dp_refine :: (Literal lit atom, Atom atom term v, Term term v f) => - Set.Set (Set.Set lit) -> [v] -> Set.Set [term] -> Set.Set [term] -> Failing (Set.Set [term]) -dp_refine cjs0 fvs dknow need = - case Set.minView dknow of - Nothing -> Success need - Just (cl, dknow') -> - let mfn = dp_mfn cjs0 . subst' . Map.fromList . zip fvs in - dpll (Set.fold mfn Set.empty (Set.union need dknow')) >>= \ flag -> - if flag then return (Set.insert cl need) else return need >>= - dp_refine cjs0 fvs dknow' - -dp_refine_loop :: forall lit atom term v f. (Literal lit atom, Term term v f, Atom atom term v) => - Set.Set (Set.Set lit) - -> Set.Set term - -> Set.Set (f, Int) - -> [v] - -> Int - -> Set.Set (Set.Set lit) - -> Set.Set [term] - -> Set.Set [term] - -> Failing (Set.Set [term]) -dp_refine_loop cjs0 cntms funcs fvs n cjs tried tuples = - dp_loop cjs0 cntms funcs fvs n cjs tried tuples >>= \ tups -> - dp_refine cjs0 fvs tups Set.empty - --- ------------------------------------------------------------------------- --- Show how few of the instances we really need. Hence unification! --- ------------------------------------------------------------------------- - -davisputnam' :: forall fof atom term lit v f pf. - (FirstOrderFormula fof atom v, - Literal lit atom, - PropositionalFormula pf atom, -- Formula pf atom, - Term term v f, - Atom atom term v, - IsString f) => - lit -> pf -> (atom -> Set.Set (f, Int)) -> fof -> Failing Int -davisputnam' _ _ fa fm = - let (sfm :: pf) = runSkolem (skolemize id ((.~.)(generalize fm))) in - let fvs = Set.toList (foldAtoms (\ s (a :: atom) -> Set.union (freeVariables a) s) Set.empty sfm) - (consts,funcs) = herbfuns fa sfm in - let cntms = Set.map (\ (c,_) -> fApp c []) consts in - dp_refine_loop (simpcnf sfm :: Set.Set (Set.Set lit)) cntms funcs fvs 0 Set.empty Set.empty Set.empty >>= return . Set.size - -{- -START_INTERACTIVE;; -let p36 = davisputnam' - <<(forall x. exists y. P(x,y)) /\ - (forall x. exists y. G(x,y)) /\ - (forall x y. P(x,y) \/ G(x,y) - ==> (forall z. P(y,z) \/ G(y,z) ==> H(x,z))) - ==> (forall x. exists y. H(x,y))>>;; - -let p29 = davisputnam' - <<(exists x. P(x)) /\ (exists x. G(x)) ==> - ((forall x. P(x) ==> H(x)) /\ (forall x. G(x) ==> J(x)) <=> - (forall x y. P(x) /\ G(y) ==> H(x) /\ J(y)))>>;; -END_INTERACTIVE;; --} diff --git a/Data/Logic/Harrison/Lib.hs b/Data/Logic/Harrison/Lib.hs deleted file mode 100644 --- a/Data/Logic/Harrison/Lib.hs +++ /dev/null @@ -1,846 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, RankNTypes, StandaloneDeriving #-} -{-# OPTIONS_GHC -Wall -fno-warn-unused-binds #-} -module Data.Logic.Harrison.Lib - ( tests - , setAny - , setAll - -- , itlist2 - -- , itlist -- same as foldr with last arguments flipped - , tryfind - , settryfind - -- , end_itlist -- same as foldr1 - , (|=>) - , (|->) - , fpf - , defined - , apply - , exists - , tryApplyD - , allpairs - , distrib' - , image - , optimize - , minimize - , maximize - , optimize' - , minimize' - , maximize' - , can - , allsets - , allsubsets - , allnonemptysubsets - , mapfilter - , setmapfilter - , (∅) - ) where - -import Data.Logic.Failing (Failing(..), failing) -import qualified Data.Map as Map -import Data.Maybe -import qualified Data.Set as Set -import Test.HUnit (Test(TestCase, TestList, TestLabel), assertEqual) - -(∅) :: Set.Set a -(∅) = Set.empty - -tests :: Test -tests = TestLabel "Data.Logic.Harrison.Lib" $ TestList [test01] - -setAny :: forall a. Ord a => (a -> Bool) -> Set.Set a -> Bool -setAny f s = Set.member True (Set.map f s) - -setAll :: forall a. Ord a => (a -> Bool) -> Set.Set a -> Bool -setAll f s = not (Set.member False (Set.map f s)) - -{- -(* ========================================================================= *) -(* Misc library functions to set up a nice environment. *) -(* ========================================================================= *) - -let identity x = x;; - -let ( ** ) = fun f g x -> f(g x);; - -(* ------------------------------------------------------------------------- *) -(* GCD and LCM on arbitrary-precision numbers. *) -(* ------------------------------------------------------------------------- *) - -let gcd_num n1 n2 = - abs_num(num_of_big_int - (Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2)));; - -let lcm_num n1 n2 = abs_num(n1 */ n2) // gcd_num n1 n2;; - -(* ------------------------------------------------------------------------- *) -(* A useful idiom for "non contradictory" etc. *) -(* ------------------------------------------------------------------------- *) - -let non p x = not(p x);; - -(* ------------------------------------------------------------------------- *) -(* Kind of assertion checking. *) -(* ------------------------------------------------------------------------- *) - -let check p x = if p(x) then x else failwith "check";; - -(* ------------------------------------------------------------------------- *) -(* Repetition of a function. *) -(* ------------------------------------------------------------------------- *) - -let rec funpow n f x = - if n < 1 then x else funpow (n-1) f (f x);; --} --- let can f x = try f x; true with Failure _ -> false;; -can :: (t -> Failing a) -> t -> Bool -can f x = failing (const True) (const False) (f x) - -{- -let rec repeat f x = try repeat f (f x) with Failure _ -> x;; - -(* ------------------------------------------------------------------------- *) -(* Handy list operations. *) -(* ------------------------------------------------------------------------- *) - -let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);; - -let rec (---) = fun m n -> if m >/ n then [] else m::((m +/ Int 1) --- n);; - -let rec map2 f l1 l2 = - match (l1,l2) with - [],[] -> [] - | (h1::t1),(h2::t2) -> let h = f h1 h2 in h::(map2 f t1 t2) - | _ -> failwith "map2: length mismatch";; - -let rev = - let rec rev_append acc l = - match l with - [] -> acc - | h::t -> rev_append (h::acc) t in - fun l -> rev_append [] l;; - -let hd l = - match l with - h::t -> h - | _ -> failwith "hd";; - -let tl l = - match l with - h::t -> t - | _ -> failwith "tl";; --} - --- (^) = (++) - -itlist :: (a -> b -> b) -> [a] -> b -> b --- itlist f xs z = foldr f z xs -itlist f xs z = foldr f z xs - -end_itlist :: (t -> t -> t) -> [t] -> t --- end_itlist = foldr1 -end_itlist = foldr1 - -itlist2 :: (t -> t1 -> Failing t2 -> Failing t2) -> [t] -> [t1] -> Failing t2 -> Failing t2 -itlist2 f l1 l2 b = - case (l1,l2) of - ([],[]) -> b - (h1 : t1, h2 : t2) -> f h1 h2 (itlist2 f t1 t2 b) - _ -> Failure ["itlist2"] - -{- -let rec zip l1 l2 = - match (l1,l2) with - ([],[]) -> [] - | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2) - | _ -> failwith "zip";; - -let rec forall p l = - match l with - [] -> true - | h::t -> p(h) & forall p t;; --} -exists :: (a -> Bool) -> [a] -> Bool -exists = any -{- -let partition p l = - itlist (fun a (yes,no) -> if p a then a::yes,no else yes,a::no) l ([],[]);; - -let filter p l = fst(partition p l);; - -let length = - let rec len k l = - if l = [] then k else len (k + 1) (tl l) in - fun l -> len 0 l;; - -let rec last l = - match l with - [x] -> x - | (h::t) -> last t - | [] -> failwith "last";; - -let rec butlast l = - match l with - [_] -> [] - | (h::t) -> h::(butlast t) - | [] -> failwith "butlast";; - -let rec find p l = - match l with - [] -> failwith "find" - | (h::t) -> if p(h) then h else find p t;; - -let rec el n l = - if n = 0 then hd l else el (n - 1) (tl l);; - -let map f = - let rec mapf l = - match l with - [] -> [] - | (x::t) -> let y = f x in y::(mapf t) in - mapf;; --} - -allpairs :: forall a b c. (Ord c) => (a -> b -> c) -> Set.Set a -> Set.Set b -> Set.Set c --- allpairs f xs ys = Set.fromList (concatMap (\ z -> map (f z) (Set.toList ys)) (Set.toList xs)) -allpairs f xs ys = Set.fold (\ x zs -> Set.fold (\ y zs' -> Set.insert (f x y) zs') zs ys) Set.empty xs - -distrib' :: Ord a => Set.Set (Set.Set a) -> Set.Set (Set.Set a) -> Set.Set (Set.Set a) -distrib' s1 s2 = allpairs (Set.union) s1 s2 - -test01 :: Test -test01 = TestCase $ assertEqual "itlist2" expected input - where input = allpairs (,) (Set.fromList [1,2,3]) (Set.fromList [4,5,6]) - expected = Set.fromList [(1,4),(1,5),(1,6),(2,4),(2,5),(2,6),(3,4),(3,5),(3,6)] :: Set.Set (Int, Int) - -{- -let rec distinctpairs l = - match l with - x::t -> itlist (fun y a -> (x,y) :: a) t (distinctpairs t) - | [] -> [];; - -let rec chop_list n l = - if n = 0 then [],l else - try let m,l' = chop_list (n-1) (tl l) in (hd l)::m,l' - with Failure _ -> failwith "chop_list";; - -let replicate n a = map (fun x -> a) (1--n);; - -let rec insertat i x l = - if i = 0 then x::l else - match l with - [] -> failwith "insertat: list too short for position to exist" - | h::t -> h::(insertat (i-1) x t);; - -let rec forall2 p l1 l2 = - match (l1,l2) with - [],[] -> true - | (h1::t1,h2::t2) -> p h1 h2 & forall2 p t1 t2 - | _ -> false;; - -let index x = - let rec ind n l = - match l with - [] -> failwith "index" - | (h::t) -> if Pervasives.compare x h = 0 then n else ind (n + 1) t in - ind 0;; - -let rec unzip l = - match l with - [] -> [],[] - | (x,y)::t -> - let xs,ys = unzip t in x::xs,y::ys;; - -(* ------------------------------------------------------------------------- *) -(* Whether the first of two items comes earlier in the list. *) -(* ------------------------------------------------------------------------- *) - -let rec earlier l x y = - match l with - h::t -> (Pervasives.compare h y <> 0) & - (Pervasives.compare h x = 0 or earlier t x y) - | [] -> false;; - -(* ------------------------------------------------------------------------- *) -(* Application of (presumably imperative) function over a list. *) -(* ------------------------------------------------------------------------- *) - -let rec do_list f l = - match l with - [] -> () - | h::t -> f(h); do_list f t;; - -(* ------------------------------------------------------------------------- *) -(* Association lists. *) -(* ------------------------------------------------------------------------- *) - -let rec assoc a l = - match l with - (x,y)::t -> if Pervasives.compare x a = 0 then y else assoc a t - | [] -> failwith "find";; - -let rec rev_assoc a l = - match l with - (x,y)::t -> if Pervasives.compare y a = 0 then x else rev_assoc a t - | [] -> failwith "find";; - -(* ------------------------------------------------------------------------- *) -(* Merging of sorted lists (maintaining repetitions). *) -(* ------------------------------------------------------------------------- *) - -let rec merge ord l1 l2 = - match l1 with - [] -> l2 - | h1::t1 -> match l2 with - [] -> l1 - | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2) - else h2::(merge ord l1 t2);; - -(* ------------------------------------------------------------------------- *) -(* Bottom-up mergesort. *) -(* ------------------------------------------------------------------------- *) - -let sort ord = - let rec mergepairs l1 l2 = - match (l1,l2) with - ([s],[]) -> s - | (l,[]) -> mergepairs [] l - | (l,[s1]) -> mergepairs (s1::l) [] - | (l,(s1::s2::ss)) -> mergepairs ((merge ord s1 s2)::l) ss in - fun l -> if l = [] then [] else mergepairs [] (map (fun x -> [x]) l);; - -(* ------------------------------------------------------------------------- *) -(* Common measure predicates to use with "sort". *) -(* ------------------------------------------------------------------------- *) - -let increasing f x y = Pervasives.compare (f x) (f y) < 0;; - -let decreasing f x y = Pervasives.compare (f x) (f y) > 0;; - -(* ------------------------------------------------------------------------- *) -(* Eliminate repetitions of adjacent elements, with and without counting. *) -(* ------------------------------------------------------------------------- *) - -let rec uniq l = - match l with - x::(y::_ as t) -> let t' = uniq t in - if Pervasives.compare x y = 0 then t' else - if t'==t then l else x::t' - | _ -> l;; - -let repetitions = - let rec repcount n l = - match l with - x::(y::_ as ys) -> if Pervasives.compare y x = 0 then repcount (n + 1) ys - else (x,n)::(repcount 1 ys) - | [x] -> [x,n] - | [] -> failwith "repcount" in - fun l -> if l = [] then [] else repcount 1 l;; --} - -tryfind :: (t -> Failing a) -> [t] -> Failing a -tryfind _ [] = Failure ["tryfind"] -tryfind f l = - case l of - [] -> Failure ["tryfind"] - h : t -> failing (\ _ -> tryfind f t) Success (f h) - -settryfind :: (t -> Failing a) -> Set.Set t -> Failing a -settryfind f l = - case Set.minView l of - Nothing -> Failure ["settryfind"] - Just (h, t) -> failing (\ _ -> settryfind f t) Success (f h) - -mapfilter :: (a -> Failing b) -> [a] -> [b] -mapfilter f l = catMaybes (map (failing (const Nothing) Just . f) l) - -- filter (failing (const False) (const True)) (map f l) - -setmapfilter :: Ord b => (a -> Failing b) -> Set.Set a -> Set.Set b -setmapfilter f s = Set.fold (\ a r -> failing (const r) (`Set.insert` r) (f a)) Set.empty s - --- ------------------------------------------------------------------------- --- Find list member that maximizes or minimizes a function. --- ------------------------------------------------------------------------- - -optimize :: forall a b. (b -> b -> Bool) -> (a -> b) -> [a] -> Maybe a -optimize _ _ [] = Nothing -optimize ord f l = Just (fst (foldr1 (\ p@(_,y) p'@(_,y') -> if ord y y' then p else p') (map (\ x -> (x,f x)) l))) - -maximize :: forall a b. Ord b => (a -> b) -> [a] -> Maybe a -maximize f l = optimize (>) f l - -minimize :: forall a b. Ord b => (a -> b) -> [a] -> Maybe a -minimize f l = optimize (<) f l - -optimize' :: forall a b. (b -> b -> Bool) -> (a -> b) -> Set.Set a -> Maybe a -optimize' ord f s = optimize ord f (Set.toList s) - -maximize' :: forall a b. Ord b => (a -> b) -> Set.Set a -> Maybe a -maximize' f s = optimize' (>) f s - -minimize' :: forall a b. Ord b => (a -> b) -> Set.Set a -> Maybe a -minimize' f s = optimize' (<) f s - --- ------------------------------------------------------------------------- --- Set operations on ordered lists. --- ------------------------------------------------------------------------- -{- -let setify = - let rec canonical lis = - match lis with - x::(y::_ as rest) -> Pervasives.compare x y < 0 & canonical rest - | _ -> true in - fun l -> if canonical l then l - else uniq (sort (fun x y -> Pervasives.compare x y <= 0) l);; - -let union = - let rec union l1 l2 = - match (l1,l2) with - ([],l2) -> l2 - | (l1,[]) -> l1 - | ((h1::t1 as l1),(h2::t2 as l2)) -> - if h1 = h2 then h1::(union t1 t2) - else if h1 < h2 then h1::(union t1 l2) - else h2::(union l1 t2) in - fun s1 s2 -> union (setify s1) (setify s2);; - -let intersect = - let rec intersect l1 l2 = - match (l1,l2) with - ([],l2) -> [] - | (l1,[]) -> [] - | ((h1::t1 as l1),(h2::t2 as l2)) -> - if h1 = h2 then h1::(intersect t1 t2) - else if h1 < h2 then intersect t1 l2 - else intersect l1 t2 in - fun s1 s2 -> intersect (setify s1) (setify s2);; - -let subtract = - let rec subtract l1 l2 = - match (l1,l2) with - ([],l2) -> [] - | (l1,[]) -> l1 - | ((h1::t1 as l1),(h2::t2 as l2)) -> - if h1 = h2 then subtract t1 t2 - else if h1 < h2 then h1::(subtract t1 l2) - else subtract l1 t2 in - fun s1 s2 -> subtract (setify s1) (setify s2);; - -let subset,psubset = - let rec subset l1 l2 = - match (l1,l2) with - ([],l2) -> true - | (l1,[]) -> false - | (h1::t1,h2::t2) -> - if h1 = h2 then subset t1 t2 - else if h1 < h2 then false - else subset l1 t2 - and psubset l1 l2 = - match (l1,l2) with - (l1,[]) -> false - | ([],l2) -> true - | (h1::t1,h2::t2) -> - if h1 = h2 then psubset t1 t2 - else if h1 < h2 then false - else subset l1 t2 in - (fun s1 s2 -> subset (setify s1) (setify s2)), - (fun s1 s2 -> psubset (setify s1) (setify s2));; - -let rec set_eq s1 s2 = (setify s1 = setify s2);; - -let insert x s = union [x] s;; --} - -image :: (Ord b, Ord a) => (a -> b) -> Set.Set a -> Set.Set b -image f s = Set.map f s - -{- -(* ------------------------------------------------------------------------- *) -(* Union of a family of sets. *) -(* ------------------------------------------------------------------------- *) - -let unions s = setify(itlist (@) s []);; - -(* ------------------------------------------------------------------------- *) -(* List membership. This does *not* assume the list is a set. *) -(* ------------------------------------------------------------------------- *) - -let rec mem x lis = - match lis with - [] -> false - | (h::t) -> Pervasives.compare x h = 0 or mem x t;; --} - --- ------------------------------------------------------------------------- --- Finding all subsets or all subsets of a given size. --- ------------------------------------------------------------------------- - --- allsets :: Ord a => Int -> Set.Set a -> Set.Set (Set.Set a) -allsets :: forall a b. (Num a, Eq a, Ord b) => a -> Set.Set b -> Set.Set (Set.Set b) -allsets 0 _ = Set.singleton Set.empty -allsets m l = - case Set.minView l of - Nothing -> Set.empty - Just (h, t) -> Set.union (Set.map (Set.insert h) (allsets (m - 1) t)) (allsets m t) - -allsubsets :: forall a. Ord a => Set.Set a -> Set.Set (Set.Set a) -allsubsets s = - maybe (Set.singleton Set.empty) - (\ (x, t) -> - let res = allsubsets t in - Set.union res (Set.map (Set.insert x) res)) - (Set.minView s) - - -allnonemptysubsets :: forall a. Ord a => Set.Set a -> Set.Set (Set.Set a) -allnonemptysubsets s = Set.delete Set.empty (allsubsets s) - -{- -(* ------------------------------------------------------------------------- *) -(* Explosion and implosion of strings. *) -(* ------------------------------------------------------------------------- *) - -let explode s = - let rec exap n l = - if n < 0 then l else - exap (n - 1) ((String.sub s n 1)::l) in - exap (String.length s - 1) [];; - -let implode l = itlist (^) l "";; - -(* ------------------------------------------------------------------------- *) -(* Timing; useful for documentation but not logically necessary. *) -(* ------------------------------------------------------------------------- *) - -let time f x = - let start_time = Sys.time() in - let result = f x in - let finish_time = Sys.time() in - print_string - ("CPU time (user): "^(string_of_float(finish_time -. start_time))); - print_newline(); - result;; --} - --- ------------------------------------------------------------------------- --- Polymorphic finite partial functions via Patricia trees. --- --- The point of this strange representation is that it is canonical (equal --- functions have the same encoding) yet reasonably efficient on average. --- --- Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). --- ------------------------------------------------------------------------- -{- -data Func a b - = Empty - | Leaf Int [(a, b)] - | Branch Int Int (Func a b) (Func a b) - --- ------------------------------------------------------------------------- --- Undefined function. --- ------------------------------------------------------------------------- - -undefinedFunction = Empty - --- ------------------------------------------------------------------------- --- In case of equality comparison worries, better use this. --- ------------------------------------------------------------------------- - -isUndefined Empty = True -isUndefined _ = False - --- ------------------------------------------------------------------------- --- Operation analogous to "map" for functions. --- ------------------------------------------------------------------------- - -mapf f t = - case t of - Empty -> Empty - Leaf h l -> Leaf h (map_list f l) - Branch p b l r -> Branch p b (mapf f l) (mapf f r) - where - map_list f l = - case l of - [] -> [] - (x,y) : t -> (x, f y) : map_list f t - --- ------------------------------------------------------------------------- --- Operations analogous to "fold" for lists. --- ------------------------------------------------------------------------- - -foldlFn f a t = - case t of - Empty -> a - Leaf h l -> foldl_list f a l - Branch p b l r -> foldlFn f (foldlFn f a l) r - where - foldl_list f a l = - case l of - [] -> a - (x,y) : t -> foldl_list f (f a x y) t - -foldrFn f t a = - case t of - Empty -> a - Leaf h l -> foldr_list f l a - Branch p b l r -> foldrFn f l (foldrFn f r a) - where - foldr_list f l a = - case l of - [] -> a - (x, y) : t -> f x y (foldr_list f t a) - --- ------------------------------------------------------------------------- --- Mapping to sorted-list representation of the graph, domain and range. --- ------------------------------------------------------------------------- - -graph f = Set.fromList (foldlFn (\ a x y -> (x,y) : a) [] f) - -dom f = Set.fromList (foldlFn (\ a x y -> x :a) [] f) - -ran f = Set.fromList (foldlFn (\ a x y -> y : a) [] f) --} - --- ------------------------------------------------------------------------- --- Application. --- ------------------------------------------------------------------------- - -applyD :: Ord k => Map.Map k a -> k -> a -> Map.Map k a -applyD m k a = Map.insert k a m - -apply :: Ord k => Map.Map k a -> k -> Maybe a -apply m k = Map.lookup k m - -tryApplyD :: Ord k => Map.Map k a -> k -> a -> a -tryApplyD m k d = fromMaybe d (Map.lookup k m) - -tryApplyL :: Ord k => Map.Map k [a] -> k -> [a] -tryApplyL m k = tryApplyD m k [] -{- -applyD :: (t -> Maybe b) -> (t -> b) -> t -> b -applyD f d x = maybe (d x) id (f x) - -apply :: (t -> Maybe b) -> t -> b -apply f = applyD f (\ _ -> error "apply") - -tryApplyD :: (t -> Maybe b) -> t -> b -> b -tryApplyD f a d = maybe d id (f a) - -tryApplyL :: (t -> Maybe [a]) -> t -> [a] -tryApplyL f x = tryApplyD f x [] --} - -defined :: Ord t => Map.Map t a -> t -> Bool -defined = flip Map.member - -{- -(* ------------------------------------------------------------------------- *) -(* Undefinition. *) -(* ------------------------------------------------------------------------- *) - -let undefine = - let rec undefine_list x l = - match l with - (a,b as ab)::t -> - let c = Pervasives.compare x a in - if c = 0 then t - else if c < 0 then l else - let t' = undefine_list x t in - if t' == t then l else ab::t' - | [] -> [] in - fun x -> - let k = Hashtbl.hash x in - let rec und t = - match t with - Leaf(h,l) when h = k -> - let l' = undefine_list x l in - if l' == l then t - else if l' = [] then Empty - else Leaf(h,l') - | Branch(p,b,l,r) when k land (b - 1) = p -> - if k land b = 0 then - let l' = und l in - if l' == l then t - else (match l' with Empty -> r | _ -> Branch(p,b,l',r)) - else - let r' = und r in - if r' == r then t - else (match r' with Empty -> l | _ -> Branch(p,b,l,r')) - | _ -> t in - und;; - -(* ------------------------------------------------------------------------- *) -(* Redefinition and combination. *) -(* ------------------------------------------------------------------------- *) - -let (|->),combine = - let newbranch p1 t1 p2 t2 = - let zp = p1 lxor p2 in - let b = zp land (-zp) in - let p = p1 land (b - 1) in - if p1 land b = 0 then Branch(p,b,t1,t2) - else Branch(p,b,t2,t1) in - let rec define_list (x,y as xy) l = - match l with - (a,b as ab)::t -> - let c = Pervasives.compare x a in - if c = 0 then xy::t - else if c < 0 then xy::l - else ab::(define_list xy t) - | [] -> [xy] - and combine_list op z l1 l2 = - match (l1,l2) with - [],_ -> l2 - | _,[] -> l1 - | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) -> - let c = Pervasives.compare x1 x2 in - if c < 0 then xy1::(combine_list op z t1 l2) - else if c > 0 then xy2::(combine_list op z l1 t2) else - let y = op y1 y2 and l = combine_list op z t1 t2 in - if z(y) then l else (x1,y)::l in - let (|->) x y = - let k = Hashtbl.hash x in - let rec upd t = - match t with - Empty -> Leaf (k,[x,y]) - | Leaf(h,l) -> - if h = k then Leaf(h,define_list (x,y) l) - else newbranch h t k (Leaf(k,[x,y])) - | Branch(p,b,l,r) -> - if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y])) - else if k land b = 0 then Branch(p,b,upd l,r) - else Branch(p,b,l,upd r) in - upd in - let rec combine op z t1 t2 = - match (t1,t2) with - Empty,_ -> t2 - | _,Empty -> t1 - | Leaf(h1,l1),Leaf(h2,l2) -> - if h1 = h2 then - let l = combine_list op z l1 l2 in - if l = [] then Empty else Leaf(h1,l) - else newbranch h1 t1 h2 t2 - | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) -> - if k land (b - 1) = p then - if k land b = 0 then - (match combine op z lf l with - Empty -> r | l' -> Branch(p,b,l',r)) - else - (match combine op z lf r with - Empty -> l | r' -> Branch(p,b,l,r')) - else - newbranch k lf p br - | (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) -> - if k land (b - 1) = p then - if k land b = 0 then - (match combine op z l lf with - Empty -> r | l' -> Branch(p,b,l',r)) - else - (match combine op z r lf with - Empty -> l | r' -> Branch(p,b,l,r')) - else - newbranch p br k lf - | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) -> - if b1 < b2 then - if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2 - else if p2 land b1 = 0 then - (match combine op z l1 t2 with - Empty -> r1 | l -> Branch(p1,b1,l,r1)) - else - (match combine op z r1 t2 with - Empty -> l1 | r -> Branch(p1,b1,l1,r)) - else if b2 < b1 then - if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2 - else if p1 land b2 = 0 then - (match combine op z t1 l2 with - Empty -> r2 | l -> Branch(p2,b2,l,r2)) - else - (match combine op z t1 r2 with - Empty -> l2 | r -> Branch(p2,b2,l2,r)) - else if p1 = p2 then - (match (combine op z l1 l2,combine op z r1 r2) with - (Empty,r) -> r | (l,Empty) -> l | (l,r) -> Branch(p1,b1,l,r)) - else - newbranch p1 t1 p2 t2 in - (|->),combine;; --} - --- ------------------------------------------------------------------------- --- Special case of point function. --- ------------------------------------------------------------------------- - -(|=>) :: Ord k => k -> a -> Map.Map k a -x |=> y = Map.fromList [(x, y)] - --- ------------------------------------------------------------------------- --- Idiom for a mapping zipping domain and range lists. --- ------------------------------------------------------------------------- - -(|->) :: Ord k => k -> a -> Map.Map k a -> Map.Map k a -(|->) a b m = Map.insert a b m - -fpf :: Ord a => Map.Map a b -> a -> Maybe b -fpf m a = Map.lookup a m - --- ------------------------------------------------------------------------- --- Grab an arbitrary element. --- ------------------------------------------------------------------------- - -choose :: Map.Map k a -> (k, a) -choose = Map.findMin - -{- -(* ------------------------------------------------------------------------- *) -(* Install a (trivial) printer for finite partial functions. *) -(* ------------------------------------------------------------------------- *) - -let print_fpf (f:('a,'b)func) = print_string "";; - -#install_printer print_fpf;; - -(* ------------------------------------------------------------------------- *) -(* Related stuff for standard functions. *) -(* ------------------------------------------------------------------------- *) - -let valmod a y f x = if x = a then y else f(x);; - -let undef x = failwith "undefined function";; - -(* ------------------------------------------------------------------------- *) -(* Union-find algorithm. *) -(* ------------------------------------------------------------------------- *) - -type ('a)pnode = Nonterminal of 'a | Terminal of 'a * int;; - -type ('a)partition = Partition of ('a,('a)pnode)func;; - -let rec terminus (Partition f as ptn) a = - match (apply f a) with - Nonterminal(b) -> terminus ptn b - | Terminal(p,q) -> (p,q);; - -let tryterminus ptn a = - try terminus ptn a with Failure _ -> (a,1);; - -let canonize ptn a = fst(tryterminus ptn a);; - -let equivalent eqv a b = canonize eqv a = canonize eqv b;; - -let equate (a,b) (Partition f as ptn) = - let (a',na) = tryterminus ptn a - and (b',nb) = tryterminus ptn b in - Partition - (if a' = b' then f else - if na <= nb then - itlist identity [a' |-> Nonterminal b'; b' |-> Terminal(b',na+nb)] f - else - itlist identity [b' |-> Nonterminal a'; a' |-> Terminal(a',na+nb)] f);; - -let unequal = Partition undefined;; - -let equated (Partition f) = dom f;; - -(* ------------------------------------------------------------------------- *) -(* First number starting at n for which p succeeds. *) -(* ------------------------------------------------------------------------- *) - -let rec first n p = if p(n) then n else first (n +/ Int 1) p;; --} diff --git a/Data/Logic/Harrison/Meson.hs b/Data/Logic/Harrison/Meson.hs deleted file mode 100644 --- a/Data/Logic/Harrison/Meson.hs +++ /dev/null @@ -1,547 +0,0 @@ -{-# LANGUAGE FlexibleContexts, RankNTypes, ScopedTypeVariables, TypeFamilies #-} -{-# OPTIONS_GHC -Wall #-} -module Data.Logic.Harrison.Meson where - -import Control.Applicative.Error (Failing(..)) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Logic.Classes.Atom (Atom) -import Data.Logic.Classes.Constants (Constants, false) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..)) -import Data.Logic.Classes.Literal (Literal) -import Data.Logic.Classes.Negate ((.~.), negative) -import Data.Logic.Classes.Propositional (PropositionalFormula) -import Data.Logic.Classes.Term (Term) -import Data.Logic.Harrison.FOL (generalize, list_conj) -import Data.Logic.Harrison.Lib (setAll, settryfind) -import Data.Logic.Harrison.Normal (simpcnf, simpdnf) -import Data.Logic.Harrison.Prolog (renamerule) -import Data.Logic.Harrison.Skolem (SkolemT, pnf, specialize, askolemize) -import Data.Logic.Harrison.Tableaux (unify_literals, deepen) - --- ========================================================================= --- Model elimination procedure (MESON version, based on Stickel's PTTP). --- --- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) --- ========================================================================= - --- ------------------------------------------------------------------------- --- Example of naivety of tableau prover. --- ------------------------------------------------------------------------- - -{- -START_INTERACTIVE;; -tab <>;; - -tab <>;; - --- ------------------------------------------------------------------------- --- The interesting example where tableaux connections make the proof longer. --- Unfortuntely this gets hammered by normalization first... --- ------------------------------------------------------------------------- - -tab <<~p /\ (p \/ q) /\ (r \/ s) /\ (~q \/ t \/ u) /\ - (~r \/ ~t) /\ (~r \/ ~u) /\ (~q \/ v \/ w) /\ - (~s \/ ~v) /\ (~s \/ ~w) ==> false>>;; -END_INTERACTIVE;; --} - --- ------------------------------------------------------------------------- --- Generation of contrapositives. --- ------------------------------------------------------------------------- - -contrapositives :: forall fof atom v. (FirstOrderFormula fof atom v, Ord fof) => Set.Set fof -> Set.Set (Set.Set fof, fof) -contrapositives cls = - if setAll negative cls then Set.insert (Set.map (.~.) cls,false) base else base - where base = Set.map (\ c -> (Set.map (.~.) (Set.delete c cls), c)) cls - --- ------------------------------------------------------------------------- --- The core of MESON: ancestor unification or Prolog-style extension. --- ------------------------------------------------------------------------- - -mexpand :: forall fof atom term v f. (FirstOrderFormula fof atom v, Literal fof atom, Term term v f, Atom atom term v, Ord fof) => - Set.Set (Set.Set fof, fof) - -> Set.Set fof - -> fof - -> ((Map.Map v term, Int, Int) -> Failing (Map.Map v term, Int, Int)) - -> (Map.Map v term, Int, Int) -> Failing (Map.Map v term, Int, Int) -mexpand rules ancestors g cont (env,n,k) = - if n < 0 - then Failure ["Too deep"] - else case settryfind doAncestor ancestors of - Success a -> Success a - Failure _ -> settryfind doRule rules - where - doAncestor a = - do mp <- unify_literals env g ((.~.) a) - cont (mp, n, k) - doRule rule = - do mp <- unify_literals env g c - mexpand' (mp, n - Set.size asm, k') - where - mexpand' = Set.fold (mexpand rules (Set.insert g ancestors)) cont asm - ((asm, c), k') = renamerule k rule - --- ------------------------------------------------------------------------- --- Full MESON procedure. --- ------------------------------------------------------------------------- - -puremeson :: forall fof atom term v f. (FirstOrderFormula fof atom v, Literal fof atom, Term term v f, Atom atom term v, Ord fof) => - Maybe Int -> fof -> Failing ((Map.Map v term, Int, Int), Int) -puremeson maxdl fm = - deepen f 0 maxdl - where - f n = mexpand rules Set.empty false return (Map.empty, n, 0) - rules = Set.fold (Set.union . contrapositives) Set.empty cls - cls = simpcnf (specialize (pnf fm)) - -meson :: forall m fof atom term f v. (FirstOrderFormula fof atom v, PropositionalFormula fof atom, Literal fof atom, Term term v f, Atom atom term v, Ord fof, Monad m) => - Maybe Int -> fof -> SkolemT v term m (Set.Set (Failing ((Map.Map v term, Int, Int), Int))) -meson maxdl fm = - askolemize ((.~.)(generalize fm)) >>= - return . Set.map (puremeson maxdl . list_conj) . (simpdnf :: fof -> Set.Set (Set.Set fof)) - -{- --- ------------------------------------------------------------------------- --- With repetition checking and divide-and-conquer search. --- ------------------------------------------------------------------------- - -let rec equal env fm1 fm2 = - try unify_literals env (fm1,fm2) == env with Failure _ -> false;; - -let expand2 expfn goals1 n1 goals2 n2 n3 cont env k = - expfn goals1 (fun (e1,r1,k1) -> - expfn goals2 (fun (e2,r2,k2) -> - if n2 + r1 <= n3 + r2 then failwith "pair" - else cont(e2,r2,k2)) - (e1,n2+r1,k1)) - (env,n1,k);; - -let rec mexpand rules ancestors g cont (env,n,k) = - if n < 0 then failwith "Too deep" - else if exists (equal env g) ancestors then failwith "repetition" else - try tryfind (fun a -> cont (unify_literals env (g,negate a),n,k)) - ancestors - with Failure _ -> tryfind - (fun r -> let (asm,c),k' = renamerule k r in - mexpands rules (g::ancestors) asm cont - (unify_literals env (g,c),n-length asm,k')) - rules - -and mexpands rules ancestors gs cont (env,n,k) = - if n < 0 then failwith "Too deep" else - let m = length gs in - if m <= 1 then itlist (mexpand rules ancestors) gs cont (env,n,k) else - let n1 = n / 2 in - let n2 = n - n1 in - let goals1,goals2 = chop_list (m / 2) gs in - let expfn = expand2 (mexpands rules ancestors) in - try expfn goals1 n1 goals2 n2 (-1) cont env k - with Failure _ -> expfn goals2 n1 goals1 n2 n1 cont env k;; - -let puremeson fm = - let cls = simpcnf(specialize(pnf fm)) in - let rules = itlist ((@) ** contrapositives) cls [] in - deepen (fun n -> - mexpand rules [] False (fun x -> x) (undefined,n,0); n) 0;; - -let meson fm = - let fm1 = askolemize(Not(generalize fm)) in - map (puremeson ** list_conj) (simpdnf fm1);; - --- ------------------------------------------------------------------------- --- The Los problem (depth 20) and the Steamroller (depth 53) --- lengthier. --- ------------------------------------------------------------------------- - -START_INTERACTIVE;; -{- *********** - -let los = meson - <<(forall x y z. P(x,y) ==> P(y,z) ==> P(x,z)) /\ - (forall x y z. Q(x,y) ==> Q(y,z) ==> Q(x,z)) /\ - (forall x y. Q(x,y) ==> Q(y,x)) /\ - (forall x y. P(x,y) \/ Q(x,y)) - ==> (forall x y. P(x,y)) \/ (forall x y. Q(x,y))>>;; - -let steamroller = meson - <<((forall x. P1(x) ==> P0(x)) /\ (exists x. P1(x))) /\ - ((forall x. P2(x) ==> P0(x)) /\ (exists x. P2(x))) /\ - ((forall x. P3(x) ==> P0(x)) /\ (exists x. P3(x))) /\ - ((forall x. P4(x) ==> P0(x)) /\ (exists x. P4(x))) /\ - ((forall x. P5(x) ==> P0(x)) /\ (exists x. P5(x))) /\ - ((exists x. Q1(x)) /\ (forall x. Q1(x) ==> Q0(x))) /\ - (forall x. P0(x) - ==> (forall y. Q0(y) ==> R(x,y)) \/ - ((forall y. P0(y) /\ S0(y,x) /\ - (exists z. Q0(z) /\ R(y,z)) - ==> R(x,y)))) /\ - (forall x y. P3(y) /\ (P5(x) \/ P4(x)) ==> S0(x,y)) /\ - (forall x y. P3(x) /\ P2(y) ==> S0(x,y)) /\ - (forall x y. P2(x) /\ P1(y) ==> S0(x,y)) /\ - (forall x y. P1(x) /\ (P2(y) \/ Q1(y)) ==> ~(R(x,y))) /\ - (forall x y. P3(x) /\ P4(y) ==> R(x,y)) /\ - (forall x y. P3(x) /\ P5(y) ==> ~(R(x,y))) /\ - (forall x. (P4(x) \/ P5(x)) ==> exists y. Q0(y) /\ R(x,y)) - ==> exists x y. P0(x) /\ P0(y) /\ - exists z. Q1(z) /\ R(y,z) /\ R(x,y)>>;; - -*************** -} - - --- ------------------------------------------------------------------------- --- Test it. --- ------------------------------------------------------------------------- - -let prop_1 = time meson - <

q <=> ~q ==> ~p>>;; - -let prop_2 = time meson - <<~ ~p <=> p>>;; - -let prop_3 = time meson - <<~(p ==> q) ==> q ==> p>>;; - -let prop_4 = time meson - <<~p ==> q <=> ~q ==> p>>;; - -let prop_5 = time meson - <<(p \/ q ==> p \/ r) ==> p \/ (q ==> r)>>;; - -let prop_6 = time meson - <

>;; - -let prop_7 = time meson - <

>;; - -let prop_8 = time meson - <<((p ==> q) ==> p) ==> p>>;; - -let prop_9 = time meson - <<(p \/ q) /\ (~p \/ q) /\ (p \/ ~q) ==> ~(~q \/ ~q)>>;; - -let prop_10 = time meson - <<(q ==> r) /\ (r ==> p /\ q) /\ (p ==> q /\ r) ==> (p <=> q)>>;; - -let prop_11 = time meson - <

p>>;; - -let prop_12 = time meson - <<((p <=> q) <=> r) <=> (p <=> (q <=> r))>>;; - -let prop_13 = time meson - <

(p \/ q) /\ (p \/ r)>>;; - -let prop_14 = time meson - <<(p <=> q) <=> (q \/ ~p) /\ (~q \/ p)>>;; - -let prop_15 = time meson - <

q <=> ~p \/ q>>;; - -let prop_16 = time meson - <<(p ==> q) \/ (q ==> p)>>;; - -let prop_17 = time meson - <

r) ==> s <=> (~p \/ q \/ s) /\ (~p \/ ~r \/ s)>>;; - --- ------------------------------------------------------------------------- --- Monadic Predicate Logic. --- ------------------------------------------------------------------------- - -let p18 = time meson - < P(x)>>;; - -let p19 = time meson - < Q(z)) ==> P(x) ==> Q(x)>>;; - -let p20 = time meson - <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w)) ==> - (exists x y. P(x) /\ Q(y)) ==> - (exists z. R(z))>>;; - -let p21 = time meson - <<(exists x. P ==> Q(x)) /\ (exists x. Q(x) ==> P) - ==> (exists x. P <=> Q(x))>>;; - -let p22 = time meson - <<(forall x. P <=> Q(x)) ==> (P <=> (forall x. Q(x)))>>;; - -let p23 = time meson - <<(forall x. P \/ Q(x)) <=> P \/ (forall x. Q(x))>>;; - -let p24 = time meson - <<~(exists x. U(x) /\ Q(x)) /\ - (forall x. P(x) ==> Q(x) \/ R(x)) /\ - ~(exists x. P(x) ==> (exists x. Q(x))) /\ - (forall x. Q(x) /\ R(x) ==> U(x)) ==> - (exists x. P(x) /\ R(x))>>;; - -let p25 = time meson - <<(exists x. P(x)) /\ - (forall x. U(x) ==> ~G(x) /\ R(x)) /\ - (forall x. P(x) ==> G(x) /\ U(x)) /\ - ((forall x. P(x) ==> Q(x)) \/ (exists x. Q(x) /\ P(x))) ==> - (exists x. Q(x) /\ P(x))>>;; - -let p26 = time meson - <<((exists x. P(x)) <=> (exists x. Q(x))) /\ - (forall x y. P(x) /\ Q(y) ==> (R(x) <=> U(y))) ==> - ((forall x. P(x) ==> R(x)) <=> (forall x. Q(x) ==> U(x)))>>;; - -let p27 = time meson - <<(exists x. P(x) /\ ~Q(x)) /\ - (forall x. P(x) ==> R(x)) /\ - (forall x. U(x) /\ V(x) ==> P(x)) /\ - (exists x. R(x) /\ ~Q(x)) ==> - (forall x. U(x) ==> ~R(x)) ==> - (forall x. U(x) ==> ~V(x))>>;; - -let p28 = time meson - <<(forall x. P(x) ==> (forall x. Q(x))) /\ - ((forall x. Q(x) \/ R(x)) ==> (exists x. Q(x) /\ R(x))) /\ - ((exists x. R(x)) ==> (forall x. L(x) ==> M(x))) ==> - (forall x. P(x) /\ L(x) ==> M(x))>>;; - -let p29 = time meson - <<(exists x. P(x)) /\ (exists x. G(x)) ==> - ((forall x. P(x) ==> H(x)) /\ (forall x. G(x) ==> J(x)) <=> - (forall x y. P(x) /\ G(y) ==> H(x) /\ J(y)))>>;; - -let p30 = time meson - <<(forall x. P(x) \/ G(x) ==> ~H(x)) /\ (forall x. (G(x) ==> ~U(x)) ==> - P(x) /\ H(x)) ==> - (forall x. U(x))>>;; - -let p31 = time meson - <<~(exists x. P(x) /\ (G(x) \/ H(x))) /\ (exists x. Q(x) /\ P(x)) /\ - (forall x. ~H(x) ==> J(x)) ==> - (exists x. Q(x) /\ J(x))>>;; - -let p32 = time meson - <<(forall x. P(x) /\ (G(x) \/ H(x)) ==> Q(x)) /\ - (forall x. Q(x) /\ H(x) ==> J(x)) /\ - (forall x. R(x) ==> H(x)) ==> - (forall x. P(x) /\ R(x) ==> J(x))>>;; - -let p33 = time meson - <<(forall x. P(a) /\ (P(x) ==> P(b)) ==> P(c)) <=> - (forall x. P(a) ==> P(x) \/ P(c)) /\ (P(a) ==> P(b) ==> P(c))>>;; - -let p34 = time meson - <<((exists x. forall y. P(x) <=> P(y)) <=> - ((exists x. Q(x)) <=> (forall y. Q(y)))) <=> - ((exists x. forall y. Q(x) <=> Q(y)) <=> - ((exists x. P(x)) <=> (forall y. P(y))))>>;; - -let p35 = time meson - < (forall x y. P(x,y))>>;; - --- ------------------------------------------------------------------------- --- Full predicate logic (without Identity and Functions) --- ------------------------------------------------------------------------- - -let p36 = time meson - <<(forall x. exists y. P(x,y)) /\ - (forall x. exists y. G(x,y)) /\ - (forall x y. P(x,y) \/ G(x,y) - ==> (forall z. P(y,z) \/ G(y,z) ==> H(x,z))) - ==> (forall x. exists y. H(x,y))>>;; - -let p37 = time meson - <<(forall z. - exists w. forall x. exists y. (P(x,z) ==> P(y,w)) /\ P(y,z) /\ - (P(y,w) ==> (exists u. Q(u,w)))) /\ - (forall x z. ~P(x,z) ==> (exists y. Q(y,z))) /\ - ((exists x y. Q(x,y)) ==> (forall x. R(x,x))) ==> - (forall x. exists y. R(x,y))>>;; - -let p38 = time meson - <<(forall x. - P(a) /\ (P(x) ==> (exists y. P(y) /\ R(x,y))) ==> - (exists z w. P(z) /\ R(x,w) /\ R(w,z))) <=> - (forall x. - (~P(a) \/ P(x) \/ (exists z w. P(z) /\ R(x,w) /\ R(w,z))) /\ - (~P(a) \/ ~(exists y. P(y) /\ R(x,y)) \/ - (exists z w. P(z) /\ R(x,w) /\ R(w,z))))>>;; - -let p39 = time meson - <<~(exists x. forall y. P(y,x) <=> ~P(y,y))>>;; - -let p40 = time meson - <<(exists y. forall x. P(x,y) <=> P(x,x)) - ==> ~(forall x. exists y. forall z. P(z,y) <=> ~P(z,x))>>;; - -let p41 = time meson - <<(forall z. exists y. forall x. P(x,y) <=> P(x,z) /\ ~P(x,x)) - ==> ~(exists z. forall x. P(x,z))>>;; - -let p42 = time meson - <<~(exists y. forall x. P(x,y) <=> ~(exists z. P(x,z) /\ P(z,x)))>>;; - -let p43 = time meson - <<(forall x y. Q(x,y) <=> forall z. P(z,x) <=> P(z,y)) - ==> forall x y. Q(x,y) <=> Q(y,x)>>;; - -let p44 = time meson - <<(forall x. P(x) ==> (exists y. G(y) /\ H(x,y)) /\ - (exists y. G(y) /\ ~H(x,y))) /\ - (exists x. J(x) /\ (forall y. G(y) ==> H(x,y))) ==> - (exists x. J(x) /\ ~P(x))>>;; - -let p45 = time meson - <<(forall x. - P(x) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y)) ==> - (forall y. G(y) /\ H(x,y) ==> R(y))) /\ - ~(exists y. L(y) /\ R(y)) /\ - (exists x. P(x) /\ (forall y. H(x,y) ==> - L(y)) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y))) ==> - (exists x. P(x) /\ ~(exists y. G(y) /\ H(x,y)))>>;; - -let p46 = time meson - <<(forall x. P(x) /\ (forall y. P(y) /\ H(y,x) ==> G(y)) ==> G(x)) /\ - ((exists x. P(x) /\ ~G(x)) ==> - (exists x. P(x) /\ ~G(x) /\ - (forall y. P(y) /\ ~G(y) ==> J(x,y)))) /\ - (forall x y. P(x) /\ P(y) /\ H(x,y) ==> ~J(y,x)) ==> - (forall x. P(x) ==> G(x))>>;; - --- ------------------------------------------------------------------------- --- Example from Manthey and Bry, CADE-9. --- ------------------------------------------------------------------------- - -let p55 = time meson - < hates(x,y) /\ ~richer(x,y)) /\ - (forall x. hates(agatha,x) ==> ~hates(charles,x)) /\ - (hates(agatha,agatha) /\ hates(agatha,charles)) /\ - (forall x. lives(x) /\ ~richer(x,agatha) ==> hates(butler,x)) /\ - (forall x. hates(agatha,x) ==> hates(butler,x)) /\ - (forall x. ~hates(x,agatha) \/ ~hates(x,butler) \/ ~hates(x,charles)) - ==> killed(agatha,agatha) /\ - ~killed(butler,agatha) /\ - ~killed(charles,agatha)>>;; - -let p57 = time meson - < P(x,z)) - ==> P(f(a,b),f(a,c))>>;; - --- ------------------------------------------------------------------------- --- See info-hol, circa 1500. --- ------------------------------------------------------------------------- - -let p58 = time meson - < ((P(v) \/ R(w)) /\ (R(z) ==> Q(v))))>>;; - -let p59 = time meson - <<(forall x. P(x) <=> ~P(f(x))) ==> (exists x. P(x) /\ ~P(f(x)))>>;; - -let p60 = time meson - < - exists y. (forall z. P(z,y) ==> P(z,f(x))) /\ P(x,y)>>;; - --- ------------------------------------------------------------------------- --- From Gilmore's classic paper. --- ------------------------------------------------------------------------- - -{- ** Amazingly, this still seems non-trivial... in HOL it works at depth 45! - -let gilmore_1 = time meson - < G(y)) <=> F(x)) /\ - ((F(y) ==> H(y)) <=> G(x)) /\ - (((F(y) ==> G(y)) ==> H(y)) <=> H(x)) - ==> F(z) /\ G(z) /\ H(z)>>;; - - ** -} - -{- ** This is not valid, according to Gilmore - -let gilmore_2 = time meson - < F(z,y)) /\ (F(z,y) <=> F(z,z)) /\ (F(x,y) <=> F(y,x)) - ==> (F(x,y) <=> F(x,z))>>;; - - ** -} - -let gilmore_3 = time meson - < (G(y) ==> H(x))) ==> F(x,x)) /\ - ((F(z,x) ==> G(x)) ==> H(z)) /\ - F(x,y) - ==> F(z,z)>>;; - -let gilmore_4 = time meson - < F(y,z) /\ F(z,z)) /\ - (F(x,y) /\ G(x,y) ==> G(x,z) /\ G(z,z))>>;; - -let gilmore_5 = time meson - <<(forall x. exists y. F(x,y) \/ F(y,x)) /\ - (forall x y. F(y,x) ==> F(y,y)) - ==> exists z. F(z,z)>>;; - -let gilmore_6 = time meson - < G(v,u) /\ G(u,x)) - ==> (exists u. forall v. F(u,y) ==> G(v,u) /\ G(u,y)) \/ - (forall u v. exists w. G(v,u) \/ H(w,y,u) ==> G(u,w))>>;; - -let gilmore_7 = time meson - <<(forall x. K(x) ==> exists y. L(y) /\ (F(x,y) ==> G(x,y))) /\ - (exists z. K(z) /\ forall u. L(u) ==> F(z,u)) - ==> exists v w. K(v) /\ L(w) /\ G(v,w)>>;; - -let gilmore_8 = time meson - < (G(y) ==> (forall u. exists v. H(u,v,x)))) ==> F(x,x)) /\ - ((F(z,x) ==> G(x)) ==> (forall u. exists v. H(u,v,z))) /\ - F(x,y) - ==> F(z,z)>>;; - -{- ** This is still a very hard problem - -let gilmore_9 = time meson - < (forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z)) - ==> (forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y))) /\ - ((forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y)) - ==> ~(forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z)) - ==> (forall u. exists v. F(y,u,v) /\ G(y,u) /\ ~H(y,x)) /\ - (forall u. exists v. F(z,u,v) /\ G(y,u) /\ ~H(z,y)))>>;; - - ** -} - --- ------------------------------------------------------------------------- --- Translation of Gilmore procedure using separate definitions. --- ------------------------------------------------------------------------- - -let gilmore_9a = time meson - <<(forall x y. P(x,y) <=> - forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y)) - ==> forall x. exists y. forall z. - (P(y,x) ==> (P(x,z) ==> P(x,y))) /\ - (P(x,y) ==> (~P(x,z) ==> P(y,x) /\ P(z,y)))>>;; - --- ------------------------------------------------------------------------- --- Example from Davis-Putnam papers where Gilmore procedure is poor. --- ------------------------------------------------------------------------- - -let davis_putnam_example = time meson - < (F(y,z) /\ F(z,z))) /\ - ((F(x,y) /\ G(x,y)) ==> (G(x,z) /\ G(z,z)))>>;; - --- ------------------------------------------------------------------------- --- The "connections make things worse" example once again. --- ------------------------------------------------------------------------- - -meson <<~p /\ (p \/ q) /\ (r \/ s) /\ (~q \/ t \/ u) /\ - (~r \/ ~t) /\ (~r \/ ~u) /\ (~q \/ v \/ w) /\ - (~s \/ ~v) /\ (~s \/ ~w) ==> false>>;; -END_INTERACTIVE;; --} diff --git a/Data/Logic/Harrison/Normal.hs b/Data/Logic/Harrison/Normal.hs deleted file mode 100644 --- a/Data/Logic/Harrison/Normal.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} --- | Versions of the normal form functions in Prop for FirstOrderFormula. -module Data.Logic.Harrison.Normal - ( trivial - , simpdnf - , simpdnf' - , simpcnf - , simpcnf' - ) where - -import Data.Logic.Classes.Combine (Combination(..), BinOp(..)) -import Data.Logic.Classes.Constants (Constants(..)) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), fromFirstOrder) -import Data.Logic.Classes.Formula (Formula(atomic)) -import Data.Logic.Classes.Literal (Literal) -import Data.Logic.Classes.Negate (Negatable, negated, (.~.)) -import Data.Logic.Failing (failing) -import Data.Logic.Harrison.Lib (setAny, allpairs) -import Data.Logic.Harrison.Skolem (nnf) -import qualified Data.Set.Extra as Set -import Prelude hiding (negate) - --- ------------------------------------------------------------------------- --- A version using a list representation. (dsf: now set) --- ------------------------------------------------------------------------- - -distrib' :: (Eq formula, Ord formula) => Set.Set (Set.Set formula) -> Set.Set (Set.Set formula) -> Set.Set (Set.Set formula) -distrib' s1 s2 = allpairs (Set.union) s1 s2 - --- ------------------------------------------------------------------------- --- Filtering out trivial disjuncts (in this guise, contradictory). --- ------------------------------------------------------------------------- - -trivial :: (Negatable lit, Ord lit) => Set.Set lit -> Bool -trivial lits = - not . Set.null $ Set.intersection neg (Set.map (.~.) pos) - where (neg, pos) = Set.partition negated lits - --- ------------------------------------------------------------------------- --- With subsumption checking, done very naively (quadratic). --- ------------------------------------------------------------------------- - -simpdnf :: (FirstOrderFormula fof atom v, Eq fof, Ord fof) => - fof -> Set.Set (Set.Set fof) -simpdnf fm = - foldFirstOrder qu co tf at fm - where - qu _ _ _ = def - co _ = def - tf False = Set.empty - tf True = Set.singleton Set.empty - at _ = Set.singleton (Set.singleton fm) - def = Set.filter keep djs - keep x = not (setAny (`Set.isProperSubsetOf` x) djs) - djs = Set.filter (not . trivial) (purednf (nnf fm)) - -purednf :: (FirstOrderFormula fof atom v, Ord fof) => fof -> Set.Set (Set.Set fof) -purednf fm = - foldFirstOrder qu co tf at fm - where - qu _ _ _ = Set.singleton (Set.singleton fm) - co (BinOp p (:&:) q) = distrib' (purednf p) (purednf q) - co (BinOp p (:|:) q) = Set.union (purednf p) (purednf q) - co _ = Set.singleton (Set.singleton fm) - tf = Set.singleton . Set.singleton . fromBool - at _ = Set.singleton (Set.singleton fm) - -simpdnf' :: forall lit fof atom v. (FirstOrderFormula fof atom v, Literal lit atom, Formula lit atom, Ord lit) => - fof -> Set.Set (Set.Set lit) -simpdnf' fm = - foldFirstOrder qu co tf at fm - where - qu _ _ _ = def - co _ = def - tf False = Set.empty - tf True = Set.singleton Set.empty - at = Set.singleton . Set.singleton . atomic - def = Set.filter keep djs - keep x = not (setAny (`Set.isProperSubsetOf` x) djs) - djs = Set.filter (not . trivial) (purednf' (nnf fm)) - -purednf' :: forall lit fof atom v. (FirstOrderFormula fof atom v, Literal lit atom, Ord lit) => - fof -> Set.Set (Set.Set lit) -purednf' fm = - foldFirstOrder (\ _ _ _ -> x) co (\ _ -> x) (\ _ -> x) fm - where - -- co :: Combination formula -> Set.Set (Set.Set lit) - co (BinOp p (:&:) q) = Set.distrib (purednf' p) (purednf' q) - co (BinOp p (:|:) q) = Set.union (purednf' p) (purednf' q) - co _ = x - -- x :: Set.Set (Set.Set lit) - x = failing (const (error "purednf'")) (Set.singleton . Set.singleton) (fromFirstOrder id fm) - --- ------------------------------------------------------------------------- --- Conjunctive normal form (CNF) by essentially the same code. --- ------------------------------------------------------------------------- - --- It would be nice to share code this way, but the caller needs to --- specify the intermediate lit type, which is a pain. --- simpcnf :: forall fof lit atom v. (FirstOrderFormula fof atom v, Ord fof, Literal lit atom v, Eq lit, Ord lit) => fof -> Set.Set (Set.Set fof) --- simpcnf fm = Set.map (Set.map (fromLiteral id :: lit -> fof)) . simpcnf' $ fm - -simpcnf :: forall fof atom v. (FirstOrderFormula fof atom v, Ord fof) => fof -> Set.Set (Set.Set fof) -simpcnf fm = - -- Set.map (Set.map (fromLiteral id :: lit -> fof)) . simpcnf' $ fm - foldFirstOrder qu co tf at fm - where - qu _ _ _ = def - co _ = def - tf False = Set.singleton Set.empty - tf True = Set.empty - at x = Set.singleton (Set.singleton (atomic x)) - -- Discard any clause that is the proper subset of another clause - def = Set.filter keep cjs - keep x = not (setAny (`Set.isProperSubsetOf` x) cjs) - cjs = Set.filter (not . trivial) (purecnf fm) - -purecnf :: forall fof atom v. (FirstOrderFormula fof atom v, Ord fof) => fof -> Set.Set (Set.Set fof) -purecnf fm = Set.map (Set.map ({-simplify .-} (.~.))) (purednf (nnf ((.~.) fm))) - --- Alternative versions, these should be merged - -simpcnf' :: forall lit fof atom v. (FirstOrderFormula fof atom v, Literal lit atom, Ord lit) => fof -> Set.Set (Set.Set lit) -simpcnf' fm = - foldFirstOrder (\ _ _ _ -> cjs') co tf at fm - where - co _ = cjs' - at = Set.singleton . Set.singleton . atomic -- foldAtomEq (\ _ _ -> cjs') tf (\ _ _ -> cjs') - tf False = Set.singleton Set.empty - tf True = Set.empty - -- Discard any clause that is the proper subset of another clause - cjs' = Set.filter keep cjs - keep x = not (Set.or (Set.map (`Set.isProperSubsetOf` x) cjs)) - cjs = Set.filter (not . trivial) (purecnf' (nnf fm)) -- :: Set.Set (Set.Set lit) - --- | CNF: (a | b | c) & (d | e | f) -purecnf' :: forall lit fof atom v. (FirstOrderFormula fof atom v, Literal lit atom, Ord lit) => fof -> Set.Set (Set.Set lit) -purecnf' fm = Set.map (Set.map (.~.)) (purednf' (nnf ((.~.) fm))) diff --git a/Data/Logic/Harrison/Prolog.hs b/Data/Logic/Harrison/Prolog.hs deleted file mode 100644 --- a/Data/Logic/Harrison/Prolog.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} -module Data.Logic.Harrison.Prolog where - -import Data.Logic.Classes.Atom (Atom) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula) -import Data.Logic.Classes.Term (Term(vt)) -import Data.String (IsString (fromString)) -import Data.Logic.Harrison.FOL (fv, subst, list_conj) -import qualified Data.Map as Map -import qualified Data.Set as Set - --- ========================================================================= --- Backchaining procedure for Horn clauses, and toy Prolog implementation. --- ========================================================================= - --- ------------------------------------------------------------------------- --- Rename a rule. --- ------------------------------------------------------------------------- - -renamerule :: forall fof atom term v f. (FirstOrderFormula fof atom v, {-Formula fof term v,-} Atom atom term v, Term term v f, Ord fof) => - Int -> (Set.Set fof, fof) -> ((Set.Set fof, fof), Int) -renamerule k (asm,c) = - ((Set.map inst asm, inst c), k + Set.size fvs) - where - fvs = fv (list_conj (Set.insert c asm)) :: Set.Set v - vvs = Map.fromList (map (\ (v, i) -> (v, vt (fromString ("_" ++ show i)))) (zip (Set.toList fvs) [k..])) :: Map.Map v term - inst = subst vvs :: fof -> fof - -{- - -(* ------------------------------------------------------------------------- *) -(* Basic prover for Horn clauses based on backchaining with unification. *) -(* ------------------------------------------------------------------------- *) - -let rec backchain rules n k env goals = - match goals with - [] -> env - | g::gs -> - if n = 0 then failwith "Too deep" else - tryfind (fun rule -> - let (a,c),k' = renamerule k rule in - backchain rules (n - 1) k' (unify_literals env (c,g)) (a @ gs)) - rules;; - -let hornify cls = - let pos,neg = partition positive cls in - if length pos > 1 then failwith "non-Horn clause" - else (map negate neg,if pos = [] then False else hd pos);; - -let hornprove fm = - let rules = map hornify (simpcnf(skolemize(Not(generalize fm)))) in - deepen (fun n -> backchain rules n 0 undefined [False],n) 0;; - -(* ------------------------------------------------------------------------- *) -(* A Horn example. *) -(* ------------------------------------------------------------------------- *) - -START_INTERACTIVE;; -let p32 = hornprove - <<(forall x. P(x) /\ (G(x) \/ H(x)) ==> Q(x)) /\ - (forall x. Q(x) /\ H(x) ==> J(x)) /\ - (forall x. R(x) ==> H(x)) - ==> (forall x. P(x) /\ R(x) ==> J(x))>>;; - -(* ------------------------------------------------------------------------- *) -(* A non-Horn example. *) -(* ------------------------------------------------------------------------- *) - -(**************** - -hornprove <<(p \/ q) /\ (~p \/ q) /\ (p \/ ~q) ==> ~(~q \/ ~q)>>;; - -**********) -END_INTERACTIVE;; - -(* ------------------------------------------------------------------------- *) -(* Parsing rules in a Prolog-like syntax. *) -(* ------------------------------------------------------------------------- *) - -let parserule s = - let c,rest = - parse_formula (parse_infix_atom,parse_atom) [] (lex(explode s)) in - let asm,rest1 = - if rest <> [] & hd rest = ":-" - then parse_list "," - (parse_formula (parse_infix_atom,parse_atom) []) (tl rest) - else [],rest in - if rest1 = [] then (asm,c) else failwith "Extra material after rule";; - -(* ------------------------------------------------------------------------- *) -(* Prolog interpreter: just use depth-first search not iterative deepening. *) -(* ------------------------------------------------------------------------- *) - -let simpleprolog rules gl = - backchain (map parserule rules) (-1) 0 undefined [parse gl];; - -(* ------------------------------------------------------------------------- *) -(* Ordering example. *) -(* ------------------------------------------------------------------------- *) - -START_INTERACTIVE;; -let lerules = ["0 <= X"; "S(X) <= S(Y) :- X <= Y"];; - -simpleprolog lerules "S(S(0)) <= S(S(S(0)))";; - -(*** simpleprolog lerules "S(S(0)) <= S(0)";; - ***) - -let env = simpleprolog lerules "S(S(0)) <= X";; -apply env "X";; -END_INTERACTIVE;; - -(* ------------------------------------------------------------------------- *) -(* With instantiation collection to produce a more readable result. *) -(* ------------------------------------------------------------------------- *) - -let prolog rules gl = - let i = solve(simpleprolog rules gl) in - mapfilter (fun x -> Atom(R("=",[Var x; apply i x]))) (fv(parse gl));; - -(* ------------------------------------------------------------------------- *) -(* Example again. *) -(* ------------------------------------------------------------------------- *) - -START_INTERACTIVE;; -prolog lerules "S(S(0)) <= X";; - -(* ------------------------------------------------------------------------- *) -(* Append example, showing symmetry between inputs and outputs. *) -(* ------------------------------------------------------------------------- *) - -let appendrules = - ["append(nil,L,L)"; "append(H::T,L,H::A) :- append(T,L,A)"];; - -prolog appendrules "append(1::2::nil,3::4::nil,Z)";; - -prolog appendrules "append(1::2::nil,Y,1::2::3::4::nil)";; - -prolog appendrules "append(X,3::4::nil,1::2::3::4::nil)";; - -prolog appendrules "append(X,Y,1::2::3::4::nil)";; - -(* ------------------------------------------------------------------------- *) -(* However this way round doesn't work. *) -(* ------------------------------------------------------------------------- *) - -(*** - *** prolog appendrules "append(X,3::4::nil,X)";; - ***) - -(* ------------------------------------------------------------------------- *) -(* A sorting example (from Lloyd's "Foundations of Logic Programming"). *) -(* ------------------------------------------------------------------------- *) - -let sortrules = - ["sort(X,Y) :- perm(X,Y),sorted(Y)"; - "sorted(nil)"; - "sorted(X::nil)"; - "sorted(X::Y::Z) :- X <= Y, sorted(Y::Z)"; - "perm(nil,nil)"; - "perm(X::Y,U::V) :- delete(U,X::Y,Z), perm(Z,V)"; - "delete(X,X::Y,Y)"; - "delete(X,Y::Z,Y::W) :- delete(X,Z,W)"; - "0 <= X"; - "S(X) <= S(Y) :- X <= Y"];; - -prolog sortrules - "sort(S(S(S(S(0))))::S(0)::0::S(S(0))::S(0)::nil,X)";; - -(* ------------------------------------------------------------------------- *) -(* Yet with a simple swap of the first two predicates... *) -(* ------------------------------------------------------------------------- *) - -let badrules = - ["sort(X,Y) :- sorted(Y), perm(X,Y)"; - "sorted(nil)"; - "sorted(X::nil)"; - "sorted(X::Y::Z) :- X <= Y, sorted(Y::Z)"; - "perm(nil,nil)"; - "perm(X::Y,U::V) :- delete(U,X::Y,Z), perm(Z,V)"; - "delete(X,X::Y,Y)"; - "delete(X,Y::Z,Y::W) :- delete(X,Z,W)"; - "0 <= X"; - "S(X) <= S(Y) :- X <= Y"];; - -(*** This no longer works - -prolog badrules - "sort(S(S(S(S(0))))::S(0)::0::S(S(0))::S(0)::nil,X)";; - - ***) -END_INTERACTIVE;; --} diff --git a/Data/Logic/Harrison/Prop.hs b/Data/Logic/Harrison/Prop.hs deleted file mode 100644 --- a/Data/Logic/Harrison/Prop.hs +++ /dev/null @@ -1,450 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies #-} -{-# OPTIONS_GHC -Wall -Wwarn #-} -module Data.Logic.Harrison.Prop - ( eval - , atoms - , onAllValuations - , TruthTable - , TruthTableRow - , truthTable - , tautology - , unsatisfiable - , satisfiable - , rawdnf - , purednf - , dnf - , dnf' - , trivial - , psimplify - , nnf - , simpdnf - , simpcnf - , positive - , negative - , negate - , distrib - , list_disj - , list_conj - -- previously unexported - , pSubst - , dual - , nenf - , mkLits - , allSatValuations - , dnf0 - , cnf - , cnf' - ) where - -import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..), binop) -import Data.Logic.Classes.Constants (Constants(fromBool, asBool), true, false, ifElse) -import Data.Logic.Classes.Formula (Formula(atomic)) -import Data.Logic.Classes.Literal (Literal(foldLiteral), toPropositional) -import Data.Logic.Classes.Negate ((.~.)) -import Data.Logic.Classes.Propositional -import Data.Logic.Harrison.Formulas.Propositional (atom_union, on_atoms) -import Data.Logic.Harrison.Lib (fpf, setAny, distrib') -import qualified Data.Map as Map -import qualified Data.Set as Set -import Prelude hiding (negate) - --- type Map a = Map.Map a Bool --- m0 = Map.empty --- ins :: forall a. Ord a => a -> Bool -> Map a -> Map a --- ins = Map.insert --- m ! k = Map.findWithDefault False k m - --- ------------------------------------------------------------------------- --- Parsing of propositional formulas. --- ------------------------------------------------------------------------- - -{- -let parse_propvar vs inp = - match inp with - p::oinp when p /= "(" -> Atom(P(p)),oinp - | _ -> failwith "parse_propvar";; - -let parse_prop_formula = make_parser - (parse_formula ((fun _ _ -> failwith ""),parse_propvar) []);; --} - --- ------------------------------------------------------------------------- --- Set this up as default for quotations. --- ------------------------------------------------------------------------- - -{- -let default_parser = parse_prop_formula;; --} - --- ------------------------------------------------------------------------- --- Printer. --- ------------------------------------------------------------------------- - -{- -let print_propvar prec p = print_string(pname p);; - -let print_prop_formula = print_qformula print_propvar;; - -#install_printer print_prop_formula;; --} - --- ------------------------------------------------------------------------- --- Interpretation of formulas. --- ------------------------------------------------------------------------- - -eval :: (PropositionalFormula formula atomic, Ord atomic) => formula -> Map.Map atomic Bool -> Bool -eval fm v = - foldPropositional co id at fm - where - co ((:~:) p) = not (eval p v) - co (BinOp p (:&:) q) = eval p v && eval q v - co (BinOp p (:|:) q) = eval p v || eval q v - co (BinOp p (:=>:) q) = not (eval p v) || eval q v - co (BinOp p (:<=>:) q) = eval p v == eval q v - at x = Map.findWithDefault False x v - -{- -START_INTERACTIVE;; -eval <

q /\ r>> - (function P"p" -> true | P"q" -> false | P"r" -> true);; - -eval <

q /\ r>> - (function P"p" -> true | P"q" -> true | P"r" -> false);; -END_INTERACTIVE;; --} - --- ------------------------------------------------------------------------- --- Return the set of propositional variables in a formula. --- ------------------------------------------------------------------------- - -atoms :: Ord atomic => PropositionalFormula formula atomic => formula -> Set.Set atomic -atoms = atom_union Set.singleton - --- ------------------------------------------------------------------------- --- Code to print out truth tables. --- ------------------------------------------------------------------------- - -onAllValuations :: (Ord a) => - (r -> r -> r) -- ^ Combine function for result type - -> (Map.Map a Bool -> r) -- ^ The substitution function - -> Map.Map a Bool -- ^ The default valuation function for atoms not in ps - -> Set.Set a -- ^ The variables to vary - -> r -onAllValuations _ subfn v ps | Set.null ps = subfn v -onAllValuations append subfn v ps = - case Set.minView ps of - Nothing -> error "onAllValuations" - Just (p, ps') -> - append -- Do the valuations of the remaining variables with set to false - (onAllValuations append subfn (Map.insert p False v) ps') - -- Do the valuations of the remaining variables with set to true - (onAllValuations append subfn (Map.insert p True v) ps') - -type TruthTableRow = ([Bool], Bool) -type TruthTable a = ([a], [TruthTableRow]) - -truthTable :: forall formula atom. (PropositionalFormula formula atom, Eq atom, Ord atom) => - formula -> TruthTable atom -truthTable fm = - (atl, onAllValuations (++) mkRow Map.empty ats) - where - mkRow :: Map.Map atom Bool -- ^ The current variable assignment - -> [TruthTableRow] -- ^ The variable assignments and the formula value - mkRow v = [(map (\ k -> Map.findWithDefault False k v) atl, eval fm v)] - atl = Set.toAscList ats - ats = atoms fm - --- ------------------------------------------------------------------------- --- Recognizing tautologies. --- ------------------------------------------------------------------------- - -tautology :: (PropositionalFormula formula atomic, Ord atomic) => formula -> Bool -tautology fm = onAllValuations (&&) (eval fm) Map.empty (atoms fm) - --- ------------------------------------------------------------------------- --- Related concepts. --- ------------------------------------------------------------------------- - - -unsatisfiable :: (PropositionalFormula formula atomic, Ord atomic) => formula -> Bool -unsatisfiable fm = tautology ((.~.) fm) - -satisfiable :: (PropositionalFormula formula atomic, Ord atomic) => formula -> Bool -satisfiable = not . unsatisfiable - --- ------------------------------------------------------------------------- --- Substitution operation. --- ------------------------------------------------------------------------- - --- pSubst :: Ord a => Map.Map a (Formula a) -> Formula a -> Formula a -pSubst :: (PropositionalFormula formula atomic, Ord atomic) => Map.Map atomic formula -> formula -> formula -pSubst subfn fm = on_atoms (\ p -> maybe (atomic p) id (fpf subfn p)) fm - --- ------------------------------------------------------------------------- --- Dualization. --- ------------------------------------------------------------------------- - -dual :: forall formula atomic. (PropositionalFormula formula atomic) => formula -> formula -dual fm = - foldPropositional co (fromBool . not) at fm - where - co ((:~:) _) = fm - co (BinOp p (:&:) q) = dual p .|. dual q - co (BinOp p (:|:) q) = dual p .&. dual q - co _ = error "dual: Formula involves connectives ==> or <=>";; - at = atomic - --- ------------------------------------------------------------------------- --- Routine simplification. --- ------------------------------------------------------------------------- - -psimplify1 :: (PropositionalFormula r a, Eq r) => r -> r -psimplify1 fm = - foldPropositional simplifyCombine (\ _ -> fm) (\ _ -> fm) fm - where - simplifyCombine ((:~:) fm') = foldPropositional simplifyNotCombine (fromBool . not) (\ _ -> fm) fm' - simplifyCombine (BinOp l op r) = - case (asBool l, op, asBool r) of - (Just True, (:&:), _ ) -> r - (Just False, (:&:), _ ) -> false - (_, (:&:), Just True ) -> l - (_, (:&:), Just False) -> false - (Just True, (:|:), _ ) -> true - (Just False, (:|:), _ ) -> r - (_, (:|:), Just True ) -> true - (_, (:|:), Just False) -> l - (Just True, (:=>:), _ ) -> r - (Just False, (:=>:), _ ) -> true - (_, (:=>:), Just True ) -> true - (_, (:=>:), Just False) -> (.~.) l - (Just True, (:<=>:), _ ) -> r - (Just False, (:<=>:), _ ) -> (.~.) r - (_, (:<=>:), Just True ) -> l - (_, (:<=>:), Just False) -> (.~.) l - _ -> fm - - simplifyNotCombine ((:~:) p) = p - simplifyNotCombine _ = fm - -psimplify :: forall formula atomic. (PropositionalFormula formula atomic, Eq formula) => formula -> formula -psimplify fm = - foldPropositional c (\ _ -> fm) (\ _ -> fm) fm - where - c :: Combination formula -> formula - c ((:~:) p) = psimplify1 ((.~.) (psimplify p)) - c (BinOp p op q) = psimplify1 (binop (psimplify p) op (psimplify q)) - --- ------------------------------------------------------------------------- --- Some operations on literals. --- ------------------------------------------------------------------------- - -negative :: forall lit atom. Literal lit atom => lit -> Bool -negative lit = - foldLiteral neg tf a lit - where - neg _ = True - tf = not - a _ = False - -positive :: Literal lit atom => lit -> Bool -positive = not . negative - -negate :: PropositionalFormula formula atomic => formula -> formula -negate lit = - foldPropositional c (fromBool . not) a lit - where - c ((:~:) p) = p - c _ = (.~.) lit - a _ = (.~.) lit - --- ------------------------------------------------------------------------- --- Negation normal form. --- ------------------------------------------------------------------------- - -nnf' :: PropositionalFormula formula atomic => formula -> formula -nnf' fm = - foldPropositional nnfCombine (\ _ -> fm) (\ _ -> fm) fm - where - nnfCombine ((:~:) p) = foldPropositional nnfNotCombine (fromBool . not) (\ _ -> fm) p - nnfCombine (BinOp p (:=>:) q) = nnf' ((.~.) p) .|. (nnf' q) - nnfCombine (BinOp p (:<=>:) q) = (nnf' p .&. nnf' q) .|. (nnf' ((.~.) p) .&. nnf' ((.~.) q)) - nnfCombine (BinOp p (:&:) q) = nnf' p .&. nnf' q - nnfCombine (BinOp p (:|:) q) = nnf' p .|. nnf' q - nnfNotCombine ((:~:) p) = nnf' p - nnfNotCombine (BinOp p (:&:) q) = nnf' ((.~.) p) .|. nnf' ((.~.) q) - nnfNotCombine (BinOp p (:|:) q) = nnf' ((.~.) p) .&. nnf' ((.~.) q) - nnfNotCombine (BinOp p (:=>:) q) = nnf' p .&. nnf' ((.~.) q) - nnfNotCombine (BinOp p (:<=>:) q) = (nnf' p .&. nnf' ((.~.) q)) .|. nnf' ((.~.) p) .&. nnf' q - --- ------------------------------------------------------------------------- --- Roll in simplification. --- ------------------------------------------------------------------------- - -nnf :: (PropositionalFormula formula atomic, Eq formula) => formula -> formula -nnf = nnf' . psimplify - --- ------------------------------------------------------------------------- --- Simple negation-pushing when we don't care to distinguish occurrences. --- ------------------------------------------------------------------------- - -nenf' :: PropositionalFormula formula atomic => formula -> formula -nenf' fm = - foldPropositional nenfCombine (\ _ -> fm) (\ _ -> fm) fm - where - nenfCombine ((:~:) p) = foldPropositional nenfNotCombine (\ _ -> fm) (\ _ -> fm) p - nenfCombine (BinOp p (:&:) q) = nenf' p .&. nenf' q - nenfCombine (BinOp p (:|:) q) = nenf' p .|. nenf' q - nenfCombine (BinOp p (:=>:) q) = nenf' ((.~.) p) .|. nenf' q - nenfCombine (BinOp p (:<=>:) q) = nenf' p .<=>. nenf' q - nenfNotCombine ((:~:) p) = p - nenfNotCombine (BinOp p (:&:) q) = nenf' ((.~.) p) .|. nenf' ((.~.) q) - nenfNotCombine (BinOp p (:|:) q) = nenf' ((.~.) p) .&. nenf' ((.~.) q) - nenfNotCombine (BinOp p (:=>:) q) = nenf' p .&. nenf' ((.~.) q) - nenfNotCombine (BinOp p (:<=>:) q) = nenf' p .<=>. nenf' ((.~.) q) -- really? how is this asymmetrical? - -nenf :: (PropositionalFormula formula atomic, Eq formula) => formula -> formula -nenf = nenf' . psimplify - -{- -# Not (prime 2) -> - <<~(~(((out_0 <=> x_0 /\ y_0) /\ ~out_1) /\ ~out_0 /\ out_1))>> - -# nenf (Not (prime 2)) -> - <<((out_0 <=> x_0 /\ y_0) /\ ~out_1) /\ ~out_0 /\ out_1>> - -> pretty ((.~.)(prime 2 :: Formula (Data.Logic.Harrison.PropExamples.Atom N))) - (out0 ⇔ x0 ∧ y0) ∧ ¬out1 ∧ out1 ∧ ¬out0 - -> pretty (nenf ((.~.)(prime 2 :: Formula (Data.Logic.Harrison.PropExamples.Atom N)))) - (out0 ⇔ x0 ∨ y0) ∨ ¬out1 ∨ out1 ∨ ¬out0 --} - --- ------------------------------------------------------------------------- --- Disjunctive normal form (DNF) via truth tables. --- ------------------------------------------------------------------------- - -list_conj :: (PropositionalFormula formula atomic, Ord formula) => Set.Set formula -> formula -list_conj l = maybe true (\ (x, xs) -> Set.fold (.&.) x xs) (Set.minView l) - -list_disj :: PropositionalFormula formula atomic => Set.Set formula -> formula -list_disj l = maybe false (\ (x, xs) -> Set.fold (.|.) x xs) (Set.minView l) - -mkLits :: (PropositionalFormula formula atomic, Ord formula, Ord atomic) => - Set.Set formula -> Map.Map atomic Bool -> formula -mkLits pvs v = list_conj (Set.map (\ p -> if eval p v then p else (.~.) p) pvs) - -allSatValuations :: Ord a => (Map.Map a Bool -> Bool) -> Map.Map a Bool -> Set.Set a -> [Map.Map a Bool] -allSatValuations subfn v pvs = - case Set.minView pvs of - Nothing -> if subfn v then [v] else [] - Just (p, ps) -> (allSatValuations subfn (Map.insert p False v) ps) ++ - (allSatValuations subfn (Map.insert p True v) ps) - -dnf0 :: forall formula atomic. (PropositionalFormula formula atomic, Ord atomic, Ord formula) => formula -> formula -dnf0 fm = - list_disj (Set.fromList (map (mkLits (Set.map atomic pvs)) satvals)) - where - satvals = allSatValuations (eval fm) Map.empty pvs - pvs = atoms fm - --- ------------------------------------------------------------------------- --- DNF via distribution. --- ------------------------------------------------------------------------- - -distrib :: PropositionalFormula formula atomic => formula -> formula -distrib fm = - foldPropositional c tf a fm - where - c (BinOp p (:&:) s) = - foldPropositional c' tf a s - where c' (BinOp q (:|:) r) = distrib (p .&. q) .|. distrib (p .&. r) - c' _ = - foldPropositional c'' tf a p - where c'' (BinOp q (:|:) r) = distrib (q .&. s) .|. distrib (r .&. s) - c'' _ = fm - c _ = fm - tf _ = fm - a _ = fm - -rawdnf :: PropositionalFormula formula atomic => formula -> formula -rawdnf fm = - foldPropositional c tf a fm - where - c (BinOp p (:&:) q) = distrib (rawdnf p .&. rawdnf q) - c (BinOp p (:|:) q) = rawdnf p .|. rawdnf q - c _ = fm - tf _ = fm - a _ = fm - --- ------------------------------------------------------------------------- --- A version using a list representation. --- ------------------------------------------------------------------------- - -purednf :: (PropositionalFormula pf atom, Literal lit atom, Ord lit) => pf -> Set.Set (Set.Set lit) -purednf fm = - foldPropositional c tf a fm - where - c (BinOp p (:&:) q) = distrib' (purednf p) (purednf q) - c (BinOp p (:|:) q) = Set.union (purednf p) (purednf q) - c ((:~:) p) = Set.map (Set.map (.~.)) (purednf p) - c _ = error "purednf" -- Set.singleton (Set.singleton fm) - tf x = Set.singleton (Set.singleton (fromBool x)) - a x = Set.singleton (Set.singleton (atomic x)) - --- ------------------------------------------------------------------------- --- Filtering out trivial disjuncts (in this guise, contradictory). --- ------------------------------------------------------------------------- - -trivial :: (Literal lit atom, Ord lit) => Set.Set lit -> Bool -trivial lits = - not . Set.null $ Set.intersection neg (Set.map (.~.) pos) - where (pos, neg) = Set.partition positive lits - --- ------------------------------------------------------------------------- --- With subsumption checking, done very naively (quadratic). --- ------------------------------------------------------------------------- - -simpdnf :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, Ord lit) => pf -> Set.Set (Set.Set lit) -simpdnf fm = - foldPropositional c tf a fm - where - c :: Combination pf -> Set.Set (Set.Set lit) - c _ = Set.filter (\ d -> not (setAny (\ d' -> Set.isProperSubsetOf d' d) djs)) djs - where djs = Set.filter (not . trivial) (purednf (nnf fm)) - tf = ifElse (Set.singleton Set.empty) Set.empty - a :: atom -> Set.Set (Set.Set lit) - a x = Set.singleton (Set.singleton (atomic x)) - --- ------------------------------------------------------------------------- --- Mapping back to a formula. --- ------------------------------------------------------------------------- - -dnf :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, Ord lit) => Set.Set (Set.Set lit) -> pf -dnf = list_disj . Set.map (list_conj . Set.map (toPropositional id)) - -dnf' :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom) => pf -> pf -dnf' = dnf . (simpdnf :: pf -> Set.Set (Set.Set pf)) - --- ------------------------------------------------------------------------- --- Conjunctive normal form (CNF) by essentially the same code. --- ------------------------------------------------------------------------- - -purecnf :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, Ord lit) => pf -> Set.Set (Set.Set lit) -purecnf fm = Set.map (Set.map (.~.)) (purednf (nnf ((.~.) fm))) - -simpcnf :: (PropositionalFormula pf atom, Literal lit atom, Ord lit) => pf -> Set.Set (Set.Set lit) -simpcnf fm = - foldPropositional c tf a fm - where - tf = ifElse Set.empty (Set.singleton Set.empty) - -- Discard any clause that is the proper subset of another clause - c _ = Set.filter keep cjs - keep x = not (setAny (`Set.isProperSubsetOf` x) cjs) - cjs = Set.filter (not . trivial) (purecnf fm) - a x = Set.singleton (Set.singleton (atomic x)) - -cnf :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, Ord lit) => Set.Set (Set.Set lit) -> pf -cnf = list_conj . Set.map (list_disj . Set.map (toPropositional id)) - -cnf' :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom) => pf -> pf -cnf' = cnf . (simpcnf :: pf -> Set.Set (Set.Set pf)) diff --git a/Data/Logic/Harrison/PropExamples.hs b/Data/Logic/Harrison/PropExamples.hs deleted file mode 100644 --- a/Data/Logic/Harrison/PropExamples.hs +++ /dev/null @@ -1,392 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeSynonymInstances #-} -module Data.Logic.Harrison.PropExamples - ( Atom(..) - , N - , prime - , ramsey - , tests - ) where - -import Data.Bits (Bits, shiftR) -import Data.Logic.Classes.Combine ((.<=>.), (.=>.), (.&.), (.|.), Combinable, Combination(..), BinOp(..)) -import Data.Logic.Classes.Constants (true, false) -import qualified Data.Logic.Classes.Formula as C -import Data.Logic.Classes.Negate ((.~.)) -import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), botFixity) -import Data.Logic.Classes.Propositional (PropositionalFormula(..)) -import Data.Logic.Harrison.Lib (allsets) -import Data.Logic.Harrison.Prop (tautology, list_conj, list_disj, psimplify) -import Data.Logic.Types.Propositional (Formula(..)) -import qualified Data.Set as Set -import Prelude hiding (sum) -import Test.HUnit -import Text.PrettyPrint (text) - -tests :: Test -tests = TestList [test01, test02, test03] - --- ========================================================================= --- Some propositional formulas to test, and functions to generate classes. --- --- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) --- ========================================================================= - --- ------------------------------------------------------------------------- --- Generate assertion equivalent to R(s,t) <= n for the Ramsey number R(s,t) --- ------------------------------------------------------------------------- - -data Atom a = P String a (Maybe a) deriving (Eq, Ord, Show) - -instance Pretty (Atom N) where - pretty (P s n mm) = text (s ++ show n ++ maybe "" (\ m -> "." ++ show m) mm) - -instance HasFixity (Atom N) where - fixity = const botFixity - -type N = Int - -ramsey :: forall formula. - (PropositionalFormula formula (Atom N), Ord formula) => - Int -> Int -> N -> formula -ramsey s t n = - let vertices = Set.fromList [1 .. n] in - let yesgrps = Set.map (allsets (2 :: Int)) (allsets s vertices) - nogrps = Set.map (allsets (2 :: Int)) (allsets t vertices) in - let e xs = let [m, n] = Set.toAscList xs in C.atomic (P "p" m (Just n)) in - list_disj (Set.map (list_conj . Set.map e) yesgrps) .|. list_disj (Set.map (list_conj . Set.map (\ p -> (.~.)(e p))) nogrps) - --- ------------------------------------------------------------------------- --- Some currently tractable examples. --- ------------------------------------------------------------------------- - -test01 :: Test -test01 = TestList [{- TestCase (assertEqual "ramsey 3 3 4" - (Combine - (BinOp - (Combine - (BinOp - (Combine - (BinOp - (Atom (P "p" 1 (Just 4))) - (:&:) - (Combine - (BinOp - (Atom (P "p" 2 (Just 4))) - (:&:) - (Atom (P "p" 1 (Just 2))))))) - (:|:) - (Combine - (BinOp - (Combine - (BinOp - (Atom (P "p" 1 (Just 4))) - (:&:) - (Combine - (BinOp - (Atom (P "p" 3 (Just 4))) - (:&:) - (Atom (P "p" 1 (Just 3))))))) - (:|:) - (Combine - (BinOp - (Combine - (BinOp - (Atom (P "p" 2 (Just 4))) - (:&:) - (Combine - (BinOp - (Atom (P "p" 3 (Just 4))) - (:&:) - (Atom (P "p" 2 (Just 3))))))) - (:|:) - (Combine - (BinOp - (Atom (P "p" 1 (Just 3))) - (:&:) - (Combine - (BinOp - (Atom (P "p" 2 (Just 3))) - (:&:) - (Atom (P "p" 1 (Just 2))))))))))))) - (:|:) - (Combine - (BinOp - (Combine - (BinOp (Combine - ((:~:) (Atom (P "p" 1 (Just 4))))) (:&:) - (Combine - (BinOp - (Combine - ((:~:) (Atom (P "p" 2 (Just 4))))) - (:&:) - (Combine - ((:~:) (Atom (P "p" 1 (Just 2))))))))) - (:|:) - (Combine - (BinOp - (Combine - (BinOp (Combine - ((:~:) (Atom (P "p" 1 (Just 4))))) - (:&:) - (Combine - (BinOp - (Combine - ((:~:) (Atom (P "p" 3 (Just 4))))) - (:&:) - (Combine - ((:~:) (Atom (P "p" 1 (Just 3))))))))) - (:|:) - (Combine - (BinOp - (Combine - (BinOp - (Combine - ((:~:) (Atom (P "p" 2 (Just 4))))) - (:&:) - (Combine - (BinOp - (Combine - ((:~:) (Atom (P "p" 3 (Just 4))))) - (:&:) - (Combine - ((:~:) (Atom (P "p" 2 (Just 3))))))))) - (:|:) - (Combine - (BinOp - (Combine - ((:~:) (Atom (P "p" 1 (Just 3))))) - (:&:) - (Combine - (BinOp - (Combine - ((:~:) (Atom (P "p" 2 (Just 3))))) - (:&:) - (Combine - ((:~:) (Atom (P "p" 1 (Just 2))))))))))))))))) - (ramsey 3 3 4 :: Formula (Atom N))), -} - TestCase (assertEqual "tautology (ramsey 3 3 5)" False (tautology (ramsey 3 3 5 :: Formula (Atom N)))), - TestCase (assertEqual "tautology (ramsey 3 3 6)" True (tautology (ramsey 3 3 6 :: Formula (Atom N))))] - --- ------------------------------------------------------------------------- --- Half adder. --- ------------------------------------------------------------------------- - -halfsum :: forall formula. Combinable formula => formula -> formula -> formula -halfsum x y = x .<=>. ((.~.) y) - -halfcarry :: forall formula. Combinable formula => formula -> formula -> formula -halfcarry x y = x .&. y - -ha :: forall formula. Combinable formula => formula -> formula -> formula -> formula -> formula -ha x y s c = (s .<=>. halfsum x y) .&. (c .<=>. halfcarry x y) - --- ------------------------------------------------------------------------- --- Full adder. --- ------------------------------------------------------------------------- - -carry :: forall formula. Combinable formula => formula -> formula -> formula -> formula -carry x y z = (x .&. y) .|. ((x .|. y) .&. z) - -sum :: forall formula. Combinable formula => formula -> formula -> formula -> formula -sum x y z = halfsum (halfsum x y) z - -fa :: forall formula. Combinable formula => formula -> formula -> formula -> formula -> formula -> formula -fa x y z s c = (s .<=>. sum x y z) .&. (c .<=>. carry x y z) - --- ------------------------------------------------------------------------- --- Useful idiom. --- ------------------------------------------------------------------------- - -conjoin :: forall formula atomic a. (PropositionalFormula formula atomic, Ord formula, Ord a) => (a -> formula) -> Set.Set a -> formula -conjoin f l = list_conj (Set.map f l) - --- ------------------------------------------------------------------------- --- n-bit ripple carry adder with carry c(0) propagated in and c(n) out. --- ------------------------------------------------------------------------- - -ripplecarry :: forall formula atomic a. (PropositionalFormula formula atomic, Ord a, Ord formula, Num a, Enum a) => - (a -> formula) - -> (a -> formula) - -> (a -> formula) - -> (a -> formula) - -> a -> formula -ripplecarry x y c out n = - conjoin (\ i -> fa (x i) (y i) (c i) (out i) (c(i + 1))) (Set.fromList [0 .. (n - 1)]) - --- ------------------------------------------------------------------------- --- Example. --- ------------------------------------------------------------------------- - -mk_index :: forall formula a. PropositionalFormula formula (Atom a) => String -> a -> formula -mk_index x i = C.atomic (P x i Nothing) -mk_index2 :: forall formula a. PropositionalFormula formula (Atom a) => String -> a -> a -> formula -mk_index2 x i j = C.atomic (P x i (Just j)) - -test02 = TestCase (assertEqual "ripplecarry x y c out 2" - (Combine (BinOp (Combine (BinOp (Combine (BinOp (Atom (P "OUT" 1 Nothing)) (:<=>:) (Combine (BinOp (Combine (BinOp (Atom (P "X" 1 Nothing)) (:<=>:) (Combine ((:~:) (Atom (P "Y" 1 Nothing)))))) (:<=>:) (Combine ((:~:) (Atom (P "C" 1 Nothing)))))))) (:&:) - (Combine (BinOp (Atom (P "C" 2 Nothing)) (:<=>:) (Combine (BinOp (Combine (BinOp (Atom (P "X" 1 Nothing)) (:&:) (Atom (P "Y" 1 Nothing)))) (:|:) (Combine (BinOp (Combine (BinOp (Atom (P "X" 1 Nothing)) (:|:) (Atom (P "Y" 1 Nothing)))) (:&:) (Atom (P "C" 1 Nothing)))))))))) (:&:) - (Combine (BinOp (Combine (BinOp (Atom (P "OUT" 0 Nothing)) (:<=>:) (Combine (BinOp (Combine (BinOp (Atom (P "X" 0 Nothing)) (:<=>:) (Combine ((:~:) (Atom (P "Y" 0 Nothing)))))) (:<=>:) (Combine ((:~:) (Atom (P "C" 0 Nothing)))))))) (:&:) - (Combine (BinOp (Atom (P "C" 1 Nothing)) (:<=>:) (Combine (BinOp (Combine (BinOp (Atom (P "X" 0 Nothing)) (:&:) (Atom (P "Y" 0 Nothing)))) (:|:) (Combine (BinOp (Combine (BinOp (Atom (P "X" 0 Nothing)) (:|:) (Atom (P "Y" 0 Nothing)))) (:&:) (Atom (P "C" 0 Nothing)))))))))))) - {- <<((OUT_0 <=> (X_0 <=> ~Y_0) <=> ~C_0) /\ - (C_1 <=> X_0 /\ Y_0 \/ (X_0 \/ Y_0) /\ C_0)) /\ - (OUT_1 <=> (X_1 <=> ~Y_1) <=> ~C_1) /\ - (C_2 <=> X_1 /\ Y_1 \/ (X_1 \/ Y_1) /\ C_1)>> -} - (let [x, y, out, c] = map mk_index ["X", "Y", "OUT", "C"] in - ripplecarry x y c out 2 :: Formula (Atom N))) - --- ------------------------------------------------------------------------- --- Special case with 0 instead of c(0). --- ------------------------------------------------------------------------- - -ripplecarry0 :: forall formula atomic a. (PropositionalFormula formula atomic, Ord formula, Ord a, Num a, Enum a) => - (a -> formula) - -> (a -> formula) - -> (a -> formula) - -> (a -> formula) - -> a -> formula -ripplecarry0 x y c out n = - psimplify - (ripplecarry x y (\ i -> if i == 0 then false else c i) out n) - --- ------------------------------------------------------------------------- --- Carry-select adder --- ------------------------------------------------------------------------- - -ripplecarry1 :: forall formula atomic a. (PropositionalFormula formula atomic, Ord formula, Ord a, Num a, Enum a) => - (a -> formula) - -> (a -> formula) - -> (a -> formula) - -> (a -> formula) - -> a -> formula -ripplecarry1 x y c out n = - psimplify - (ripplecarry x y (\ i -> if i == 0 then true else c i) out n) - -mux :: forall formula. Combinable formula => formula -> formula -> formula -> formula -mux sel in0 in1 = (((.~.) sel) .&. in0) .|. (sel .&. in1) - -offset :: forall t a. Num a => a -> (a -> t) -> a -> t -offset n x i = x (n + i) - -carryselect :: forall formula atomic a. (PropositionalFormula formula atomic, Ord a, Ord formula, Num a, Enum a) => - (a -> formula) - -> (a -> formula) - -> (a -> formula) - -> (a -> formula) - -> (a -> formula) - -> (a -> formula) - -> (a -> formula) - -> (a -> formula) - -> a -> a -> formula -carryselect x y c0 c1 s0 s1 c s n k = - let k' = min n k in - let fm = ((ripplecarry0 x y c0 s0 k') .&. (ripplecarry1 x y c1 s1 k')) .&. - (((c k') .<=>. (mux (c 0) (c0 k') (c1 k'))) .&. - (conjoin (\ i -> (s i) .<=>. (mux (c 0) (s0 i) (s1 i))) - (Set.fromList [0 .. (k' - 1)]))) in - if k' < k then fm else - fm .&. (carryselect - (offset k x) (offset k y) (offset k c0) (offset k c1) - (offset k s0) (offset k s1) (offset k c) (offset k s) - (n - k) k) - --- ------------------------------------------------------------------------- --- Equivalence problems for carry-select vs ripple carry adders. --- ------------------------------------------------------------------------- - -mk_adder_test :: forall formula a. (PropositionalFormula formula (Atom a), Ord a, Ord formula, Num a, Enum a) => - a -> a -> formula -mk_adder_test n k = - let [x, y, c, s, c0, s0, c1, s1, c2, s2] = - map mk_index ["x", "y", "c", "s", "c0", "s0", "c1", "s1", "c2", "s2"] in - (((carryselect x y c0 c1 s0 s1 c s n k) .&. - ((.~.) (c 0))) .&. - (ripplecarry0 x y c2 s2 n)) .=>. - (((c n) .<=>. (c2 n)) .&. - (conjoin (\ i -> (s i) .<=>. (s2 i)) (Set.fromList [0 .. (n - 1)]))) - --- ------------------------------------------------------------------------- --- Ripple carry stage that separates off the final result. --- --- UUUUUUUUUUUUUUUUUUUU (u) --- + VVVVVVVVVVVVVVVVVVVV (v) --- --- = WWWWWWWWWWWWWWWWWWWW (w) --- + Z (z) --- ------------------------------------------------------------------------- - -rippleshift :: forall formula atomic a. (PropositionalFormula formula atomic, Ord a, Ord formula, Num a, Enum a) => - (a -> formula) - -> (a -> formula) - -> (a -> formula) - -> formula - -> (a -> formula) - -> a -> formula -rippleshift u v c z w n = - ripplecarry0 u v (\ i -> if i == n then w(n - 1) else c(i + 1)) - (\ i -> if i == 0 then z else w(i - 1)) n --- ------------------------------------------------------------------------- --- Naive multiplier based on repeated ripple carry. --- ------------------------------------------------------------------------- - -multiplier :: forall formula atomic a. (PropositionalFormula formula atomic, Ord a, Ord formula, Num a, Enum a) => - (a -> a -> formula) - -> (a -> a -> formula) - -> (a -> a -> formula) - -> (a -> formula) - -> a - -> formula -multiplier x u v out n = - if n == 1 then ((out 0) .<=>. (x 0 0)) .&. ((.~.)(out 1)) else - psimplify (((out 0) .<=>. (x 0 0)) .&. - ((rippleshift - (\ i -> if i == n - 1 then false else x 0 (i + 1)) - (x 1) (v 2) (out 1) (u 2) n) .&. - (if n == 2 then ((out 2) .<=>. (u 2 0)) .&. ((out 3) .<=>. (u 2 1)) else - conjoin (\ k -> rippleshift (u k) (x k) (v(k + 1)) (out k) - (if k == n - 1 then \ i -> out(n + i) - else u(k + 1)) n) (Set.fromList [2 .. (n - 1)])))) - --- ------------------------------------------------------------------------- --- Primality examples. --- For large examples, should use "num" instead of "int" in these functions. --- ------------------------------------------------------------------------- - -bitlength :: forall b a. (Num a, Num b, Bits b) => b -> a -bitlength x = if x == 0 then 0 else 1 + bitlength (shiftR x 1);; - -bit :: forall a b. (Num a, Eq a, Bits b, Integral b) => a -> b -> Bool -bit n x = if n == 0 then x `mod` 2 == 1 else bit (n - 1) (shiftR x 1) - -congruent_to :: forall formula atomic a b. (Bits b, PropositionalFormula formula atomic, Ord a, Ord formula, Num a, Integral b, Enum a) => - (a -> formula) -> b -> a -> formula -congruent_to x m n = - conjoin (\ i -> if bit i m then x i else (.~.)(x i)) - (Set.fromList [0 .. (n - 1)]) - -prime :: forall formula. (PropositionalFormula formula (Atom N), Ord formula) => N -> formula -prime p = - let [x, y, out] = map mk_index ["x", "y", "out"] in - let m i j = (x i) .&. (y j) - [u, v] = map mk_index2 ["u", "v"] in - let (n :: Int) = bitlength p in - (.~.) (multiplier m u v out (n - 1) .&. congruent_to out p (max n (2 * n - 2))) - --- ------------------------------------------------------------------------- --- Examples. --- ------------------------------------------------------------------------- - -type F = Formula (Atom Int) - -deriving instance Show F - -{- -instance Constants F where - fromBool True = --} - -test03 :: Test -test03 = - TestList [TestCase (assertEqual "tautology(prime 7)" True (tautology(prime 7 :: F))), - TestCase (assertEqual "tautology(prime 9)" False (tautology(prime 9 :: F))), - TestCase (assertEqual "tautology(prime 11)" True (tautology(prime 11 :: F)))] diff --git a/Data/Logic/Harrison/Resolution.hs b/Data/Logic/Harrison/Resolution.hs deleted file mode 100644 --- a/Data/Logic/Harrison/Resolution.hs +++ /dev/null @@ -1,1045 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} -module Data.Logic.Harrison.Resolution - ( resolution1 - , resolution2 - , resolution3 - , presolution - , matchAtomsEq - ) where - -import Data.Logic.Classes.Atom (Atom(match)) -import Data.Logic.Classes.Combine (Combination(..)) -import Data.Logic.Classes.Equals (AtomEq, zipAtomsEq) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), zipFirstOrder) -import Data.Logic.Classes.Literal (Literal) -import Data.Logic.Classes.Negate ((.~.), positive) -import Data.Logic.Classes.Propositional (PropositionalFormula) -import Data.Logic.Classes.Term (Term(vt, foldTerm)) -import Data.Logic.Classes.Variable (Variable(prefix)) -import Data.Logic.Failing (Failing(..), failing) -import Data.Logic.Harrison.FOL (subst, fv, generalize, list_disj, list_conj) -import Data.Logic.Harrison.Lib (settryfind, allpairs, allsubsets, setAny, setAll, - allnonemptysubsets, (|->), apply, defined) -import Data.Logic.Harrison.Normal (simpdnf, simpcnf, trivial) -import Data.Logic.Harrison.Skolem (pnf, SkolemT, askolemize, specialize) -import Data.Logic.Harrison.Tableaux (unify_literals) -import Data.Logic.Harrison.Unif (solve) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import qualified Data.Set as Set - --- ========================================================================= --- Resolution. --- --- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) --- ========================================================================= - --- ------------------------------------------------------------------------- --- MGU of a set of literals. --- ------------------------------------------------------------------------- - -mgu :: forall lit atom term v f. (Literal lit atom, Term term v f, Atom atom term v) => - Set.Set lit -> Map.Map v term -> Failing (Map.Map v term) -mgu l env = - case Set.minView l of - Just (a, rest) -> - case Set.minView rest of - Just (b, _) -> unify_literals env a b >>= mgu rest - _ -> Success (solve env) - _ -> Success (solve env) - -unifiable :: (Literal lit atom, Term term v f, Atom atom term v) => - lit -> lit -> Bool -unifiable p q = failing (const False) (const True) (unify_literals Map.empty p q) - --- ------------------------------------------------------------------------- --- Rename a clause. --- ------------------------------------------------------------------------- - -rename :: (FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) => - (v -> v) -> Set.Set fof -> Set.Set fof -rename pfx cls = - Set.map (subst (Map.fromList (zip fvs vvs))) cls - where - -- fvs :: [v] - fvs = Set.toList (fv (list_disj cls)) - -- vvs :: [term] - vvs = map (vt . pfx) fvs - --- ------------------------------------------------------------------------- --- General resolution rule, incorporating factoring as in Robinson's paper. --- ------------------------------------------------------------------------- - -resolvents :: (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) => - Set.Set fof -> Set.Set fof -> fof -> Set.Set fof -> Set.Set fof -resolvents cl1 cl2 p acc = - if Set.null ps2 then acc else Set.fold doPair acc pairs - where - doPair (s1,s2) sof = - case mgu (Set.union s1 (Set.map (.~.) s2)) Map.empty of - Success mp -> Set.union (Set.map (subst mp) (Set.union (Set.difference cl1 s1) (Set.difference cl2 s2))) sof - Failure _ -> sof - -- pairs :: Set.Set (Set.Set fof, Set.Set fof) - pairs = allpairs (,) (Set.map (Set.insert p) (allsubsets ps1)) (allnonemptysubsets ps2) - -- ps1 :: Set.Set fof - ps1 = Set.filter (\ q -> q /= p && unifiable p q) cl1 - -- ps2 :: Set.Set fof - ps2 = Set.filter (unifiable ((.~.) p)) cl2 - -resolve_clauses :: forall fof atom v term f. - (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) => - Set.Set fof -> Set.Set fof -> Set.Set fof -resolve_clauses cls1 cls2 = - let cls1' = rename (prefix "x") cls1 - cls2' = rename (prefix "y") cls2 in - Set.fold (resolvents cls1' cls2') Set.empty cls1' - --- ------------------------------------------------------------------------- --- Basic "Argonne" loop. --- ------------------------------------------------------------------------- - -resloop1 :: forall atom v term f fof. (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) => - Set.Set (Set.Set fof) -> Set.Set (Set.Set fof) -> Failing Bool -resloop1 used unused = - maybe (Failure ["No proof found"]) step (Set.minView unused) - where - step (cl, ros) = - if Set.member Set.empty news then return True else resloop1 used' (Set.union ros news) - where - used' = Set.insert cl used - -- resolve_clauses is not in the Failing monad, so setmapfilter isn't appropriate. - news = Set.fold Set.insert Set.empty ({-setmapfilter-} Set.map (resolve_clauses cl) used') - -pure_resolution1 :: forall fof atom v term f. (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) => - fof -> Failing Bool -pure_resolution1 fm = resloop1 Set.empty (simpcnf (specialize (pnf fm))) - -resolution1 :: forall m fof term f atom v. - (Literal fof atom, - FirstOrderFormula fof atom v, - PropositionalFormula fof atom, - Term term v f, - Atom atom term v, - Ord fof, - Monad m) => - fof -> SkolemT v term m (Set.Set (Failing Bool)) -resolution1 fm = askolemize ((.~.)(generalize fm)) >>= return . Set.map (pure_resolution1 . list_conj) . (simpdnf :: fof -> Set.Set (Set.Set fof)) - --- ------------------------------------------------------------------------- --- Matching of terms and literals. --- ------------------------------------------------------------------------- - -term_match :: forall term v f. (Term term v f) => Map.Map v term -> [(term, term)] -> Failing (Map.Map v term) -term_match env [] = Success env -term_match env ((p, q) : oth) = - foldTerm v fn p - where - v x = if not (defined env x) - then term_match ((x |-> q) env) oth - else if apply env x == Just q - then term_match env oth - else Failure ["term_match"] - fn f fa = - foldTerm v' fn' q - where - fn' g ga | f == g && length fa == length ga = term_match env (zip fa ga ++ oth) - fn' _ _ = Failure ["term_match"] - v' _ = Failure ["term_match"] -{- - case eqs of - [] -> Success env - (Fn f fa, Fn g ga) : oth - | f == g && length fa == length ga -> - term_match env (zip fa ga ++ oth) - (Var x, t) : oth -> - if not (defined env x) then term_match ((x |-> t) env) oth - else if apply env x == t then term_match env oth - else Failure ["term_match"] - _ -> Failure ["term_match"] --} - -match_literals :: forall term f v fof atom. (FirstOrderFormula fof atom v, Atom atom term v, Term term v f) => - Map.Map v term -> fof -> fof -> Failing (Map.Map v term) -match_literals env t1 t2 = - fromMaybe err (zipFirstOrder qu co tf at t1 t2) - where - qu _ _ _ _ _ _ = Nothing - co ((:~:) p) ((:~:) q) = Just $ match_literals env p q - co _ _ = Nothing - tf a b = if a == b then Just (Success env) else Nothing - at a1 a2 = Just (match env a1 a2) - err = Failure ["match_literals"] - --- Identical to unifyAtomsEq except calls term_match instead of unify. -matchAtomsEq :: forall v f atom p term. - (AtomEq atom p term, Term term v f) => - Map.Map v term -> atom -> atom -> Failing (Map.Map v term) -matchAtomsEq env a1 a2 = - fromMaybe err (zipAtomsEq ap tf eq a1 a2) - where - ap p ts1 q ts2 = - if p == q && length ts1 == length ts2 - then Just (term_match env (zip ts1 ts2)) - else Nothing - tf p q = if p == q then Just (Success env) else Nothing - eq pl pr ql qr = Just (term_match env [(pl, ql), (pr, qr)]) - err = Failure ["matchAtomsEq"] - -{- - case tmp of - (Atom (R p a1), Atom(R q a2)) -> term_match env [(Fn p a1, Fn q a2)] - (Not (Atom (R p a1)), Not (Atom (R q a2))) -> term_match env [(Fn p a1, Fn q a2)] - _ -> Failure ["match_literals"] --} - --- ------------------------------------------------------------------------- --- Test for subsumption --- ------------------------------------------------------------------------- - -subsumes_clause :: forall term f v fof atom. (FirstOrderFormula fof atom v, Term term v f, Atom atom term v) => - Set.Set fof -> Set.Set fof -> Bool -subsumes_clause cls1 cls2 = - failing (const False) (const True) (subsume Map.empty cls1) - where - -- subsume :: Map.Map v term -> Set.Set fof -> Failing (Map.Map v term) - subsume env cls = - case Set.minView cls of - Nothing -> Success env - Just (l1, clt) -> settryfind (\ l2 -> case (match_literals env l1 l2) of - Success env' -> subsume env' clt - Failure msgs -> Failure msgs) cls2 --- ------------------------------------------------------------------------- --- With deletion of tautologies and bi-subsumption with "unused". --- ------------------------------------------------------------------------- - -replace :: forall term f v fof atom. (FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) => - Set.Set fof - -> Set.Set (Set.Set fof) - -> Set.Set (Set.Set fof) -replace cl st = - case Set.minView st of - Nothing -> Set.singleton cl - Just (c, st') -> if subsumes_clause cl c - then Set.insert cl st' - else Set.insert c (replace cl st') - -incorporate :: forall fof term f v atom. (FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) => - Set.Set fof - -> Set.Set fof - -> Set.Set (Set.Set fof) - -> Set.Set (Set.Set fof) -incorporate gcl cl unused = - if trivial cl || setAny (\ c -> subsumes_clause c cl) (Set.insert gcl unused) - then unused - else replace cl unused - -resloop2 :: forall fof term f v atom. (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) => - Set.Set (Set.Set fof) - -> Set.Set (Set.Set fof) - -> Failing Bool -resloop2 used unused = - case Set.minView unused of - Nothing -> Failure ["No proof found"] - Just (cl {- :: Set.Set fof-}, ros {- :: Set.Set (Set.Set fof) -}) -> - -- print_string(string_of_int(length used) ^ " used; "^ string_of_int(length unused) ^ " unused."); - -- print_newline(); - let used' = Set.insert cl used in - let news = {-Set.fold Set.union Set.empty-} (Set.map (resolve_clauses cl) used') in - if Set.member Set.empty news then return True else resloop2 used' (Set.fold (incorporate cl) ros news) - -pure_resolution2 :: forall fof atom v term f. (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) => - fof -> Failing Bool -pure_resolution2 fm = resloop2 Set.empty (simpcnf (specialize (pnf fm))) - -resolution2 :: forall fof atom term v f m. - (Literal fof atom, FirstOrderFormula fof atom v, PropositionalFormula fof atom, Term term v f, Atom atom term v, Ord fof, Monad m) => - fof -> SkolemT v term m (Set.Set (Failing Bool)) -resolution2 fm = askolemize ((.~.) (generalize fm)) >>= return . Set.map (pure_resolution2 . list_conj) . (simpdnf :: fof -> Set.Set (Set.Set fof)) - --- ------------------------------------------------------------------------- --- Positive (P1) resolution. --- ------------------------------------------------------------------------- - -presolve_clauses :: (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) => - Set.Set fof -> Set.Set fof -> Set.Set fof -presolve_clauses cls1 cls2 = - if setAll positive cls1 || setAll positive cls2 - then resolve_clauses cls1 cls2 - else Set.empty - -presloop :: (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) => - Set.Set (Set.Set fof) -> Set.Set (Set.Set fof) -> Failing Bool -presloop used unused = - case Set.minView unused of - Nothing -> Failure ["No proof found"] - Just (cl, ros) -> - -- print_string(string_of_int(length used) ^ " used; "^ string_of_int(length unused) ^ " unused."); - -- print_newline(); - let used' = Set.insert cl used in - let news = Set.map (presolve_clauses cl) used' in - if Set.member Set.empty news - then Success True - else presloop used' (Set.fold (incorporate cl) ros news) - -pure_presolution :: forall fof atom v term f. (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) => - fof -> Failing Bool -pure_presolution fm = presloop Set.empty (simpcnf (specialize (pnf fm))) - -presolution :: forall fof atom term v f m. - (Literal fof atom, FirstOrderFormula fof atom v, PropositionalFormula fof atom, Term term v f, Atom atom term v, Ord fof, Monad m) => - fof -> SkolemT v term m (Set.Set (Failing Bool)) -presolution fm = - askolemize ((.~.) (generalize fm)) >>= return . Set.map (pure_presolution . list_conj) . (simpdnf :: fof -> Set.Set (Set.Set fof)) - --- ------------------------------------------------------------------------- --- Introduce a set-of-support restriction. --- ------------------------------------------------------------------------- - -pure_resolution3 :: (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) => - fof -> Failing Bool -pure_resolution3 fm = - uncurry resloop2 (Set.partition (setAny positive) (simpcnf (specialize (pnf fm)))) - -resolution3 :: forall fof atom term v f m. (Literal fof atom, FirstOrderFormula fof atom v, PropositionalFormula fof atom, Term term v f, Atom atom term v, Ord fof, Monad m) => - fof -> SkolemT v term m (Set.Set (Failing Bool)) -resolution3 fm = - askolemize ((.~.)(generalize fm)) >>= return . Set.map (pure_resolution3 . list_conj) . (simpdnf :: fof -> Set.Set (Set.Set fof)) -{- --- ------------------------------------------------------------------------- --- The Pelletier examples again. --- ------------------------------------------------------------------------- - -{- ********** - -let p1 = time presolution - <

q <=> ~q ==> ~p>>;; - -let p2 = time presolution - <<~ ~p <=> p>>;; - -let p3 = time presolution - <<~(p ==> q) ==> q ==> p>>;; - -let p4 = time presolution - <<~p ==> q <=> ~q ==> p>>;; - -let p5 = time presolution - <<(p \/ q ==> p \/ r) ==> p \/ (q ==> r)>>;; - -let p6 = time presolution - <

>;; - -let p7 = time presolution - <

>;; - -let p8 = time presolution - <<((p ==> q) ==> p) ==> p>>;; - -let p9 = time presolution - <<(p \/ q) /\ (~p \/ q) /\ (p \/ ~q) ==> ~(~q \/ ~q)>>;; - -let p10 = time presolution - <<(q ==> r) /\ (r ==> p /\ q) /\ (p ==> q /\ r) ==> (p <=> q)>>;; - -let p11 = time presolution - <

p>>;; - -let p12 = time presolution - <<((p <=> q) <=> r) <=> (p <=> (q <=> r))>>;; - -let p13 = time presolution - <

(p \/ q) /\ (p \/ r)>>;; - -let p14 = time presolution - <<(p <=> q) <=> (q \/ ~p) /\ (~q \/ p)>>;; - -let p15 = time presolution - <

q <=> ~p \/ q>>;; - -let p16 = time presolution - <<(p ==> q) \/ (q ==> p)>>;; - -let p17 = time presolution - <

r) ==> s <=> (~p \/ q \/ s) /\ (~p \/ ~r \/ s)>>;; - --- ------------------------------------------------------------------------- --- Monadic Predicate Logic. --- ------------------------------------------------------------------------- - -let p18 = time presolution - < P(x)>>;; - -let p19 = time presolution - < Q(z)) ==> P(x) ==> Q(x)>>;; - -let p20 = time presolution - <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w)) - ==> (exists x y. P(x) /\ Q(y)) ==> (exists z. R(z))>>;; - -let p21 = time presolution - <<(exists x. P ==> Q(x)) /\ (exists x. Q(x) ==> P) - ==> (exists x. P <=> Q(x))>>;; - -let p22 = time presolution - <<(forall x. P <=> Q(x)) ==> (P <=> (forall x. Q(x)))>>;; - -let p23 = time presolution - <<(forall x. P \/ Q(x)) <=> P \/ (forall x. Q(x))>>;; - -let p24 = time presolution - <<~(exists x. U(x) /\ Q(x)) /\ - (forall x. P(x) ==> Q(x) \/ R(x)) /\ - ~(exists x. P(x) ==> (exists x. Q(x))) /\ - (forall x. Q(x) /\ R(x) ==> U(x)) ==> - (exists x. P(x) /\ R(x))>>;; - -let p25 = time presolution - <<(exists x. P(x)) /\ - (forall x. U(x) ==> ~G(x) /\ R(x)) /\ - (forall x. P(x) ==> G(x) /\ U(x)) /\ - ((forall x. P(x) ==> Q(x)) \/ (exists x. Q(x) /\ P(x))) ==> - (exists x. Q(x) /\ P(x))>>;; - -let p26 = time presolution - <<((exists x. P(x)) <=> (exists x. Q(x))) /\ - (forall x y. P(x) /\ Q(y) ==> (R(x) <=> U(y))) ==> - ((forall x. P(x) ==> R(x)) <=> (forall x. Q(x) ==> U(x)))>>;; - -let p27 = time presolution - <<(exists x. P(x) /\ ~Q(x)) /\ - (forall x. P(x) ==> R(x)) /\ - (forall x. U(x) /\ V(x) ==> P(x)) /\ - (exists x. R(x) /\ ~Q(x)) ==> - (forall x. U(x) ==> ~R(x)) ==> - (forall x. U(x) ==> ~V(x))>>;; - -let p28 = time presolution - <<(forall x. P(x) ==> (forall x. Q(x))) /\ - ((forall x. Q(x) \/ R(x)) ==> (exists x. Q(x) /\ R(x))) /\ - ((exists x. R(x)) ==> (forall x. L(x) ==> M(x))) ==> - (forall x. P(x) /\ L(x) ==> M(x))>>;; - -let p29 = time presolution - <<(exists x. P(x)) /\ (exists x. G(x)) ==> - ((forall x. P(x) ==> H(x)) /\ (forall x. G(x) ==> J(x)) <=> - (forall x y. P(x) /\ G(y) ==> H(x) /\ J(y)))>>;; - -let p30 = time presolution - <<(forall x. P(x) \/ G(x) ==> ~H(x)) /\ - (forall x. (G(x) ==> ~U(x)) ==> P(x) /\ H(x)) ==> - (forall x. U(x))>>;; - -let p31 = time presolution - <<~(exists x. P(x) /\ (G(x) \/ H(x))) /\ (exists x. Q(x) /\ P(x)) /\ - (forall x. ~H(x) ==> J(x)) ==> - (exists x. Q(x) /\ J(x))>>;; - -let p32 = time presolution - <<(forall x. P(x) /\ (G(x) \/ H(x)) ==> Q(x)) /\ - (forall x. Q(x) /\ H(x) ==> J(x)) /\ - (forall x. R(x) ==> H(x)) ==> - (forall x. P(x) /\ R(x) ==> J(x))>>;; - -let p33 = time presolution - <<(forall x. P(a) /\ (P(x) ==> P(b)) ==> P(c)) <=> - (forall x. P(a) ==> P(x) \/ P(c)) /\ (P(a) ==> P(b) ==> P(c))>>;; - -let p34 = time presolution - <<((exists x. forall y. P(x) <=> P(y)) <=> - ((exists x. Q(x)) <=> (forall y. Q(y)))) <=> - ((exists x. forall y. Q(x) <=> Q(y)) <=> - ((exists x. P(x)) <=> (forall y. P(y))))>>;; - -let p35 = time presolution - < (forall x y. P(x,y))>>;; - --- ------------------------------------------------------------------------- --- Full predicate logic (without Identity and Functions) --- ------------------------------------------------------------------------- - -let p36 = time presolution - <<(forall x. exists y. P(x,y)) /\ - (forall x. exists y. G(x,y)) /\ - (forall x y. P(x,y) \/ G(x,y) - ==> (forall z. P(y,z) \/ G(y,z) ==> H(x,z))) - ==> (forall x. exists y. H(x,y))>>;; - -let p37 = time presolution - <<(forall z. - exists w. forall x. exists y. (P(x,z) ==> P(y,w)) /\ P(y,z) /\ - (P(y,w) ==> (exists u. Q(u,w)))) /\ - (forall x z. ~P(x,z) ==> (exists y. Q(y,z))) /\ - ((exists x y. Q(x,y)) ==> (forall x. R(x,x))) ==> - (forall x. exists y. R(x,y))>>;; - -{- ** This one seems too slow - -let p38 = time presolution - <<(forall x. - P(a) /\ (P(x) ==> (exists y. P(y) /\ R(x,y))) ==> - (exists z w. P(z) /\ R(x,w) /\ R(w,z))) <=> - (forall x. - (~P(a) \/ P(x) \/ (exists z w. P(z) /\ R(x,w) /\ R(w,z))) /\ - (~P(a) \/ ~(exists y. P(y) /\ R(x,y)) \/ - (exists z w. P(z) /\ R(x,w) /\ R(w,z))))>>;; - - ** -} - -let p39 = time presolution - <<~(exists x. forall y. P(y,x) <=> ~P(y,y))>>;; - -let p40 = time presolution - <<(exists y. forall x. P(x,y) <=> P(x,x)) - ==> ~(forall x. exists y. forall z. P(z,y) <=> ~P(z,x))>>;; - -let p41 = time presolution - <<(forall z. exists y. forall x. P(x,y) <=> P(x,z) /\ ~P(x,x)) - ==> ~(exists z. forall x. P(x,z))>>;; - -{- ** Also very slow - -let p42 = time presolution - <<~(exists y. forall x. P(x,y) <=> ~(exists z. P(x,z) /\ P(z,x)))>>;; - - ** -} - -{- ** and this one too.. - -let p43 = time presolution - <<(forall x y. Q(x,y) <=> forall z. P(z,x) <=> P(z,y)) - ==> forall x y. Q(x,y) <=> Q(y,x)>>;; - - ** -} - -let p44 = time presolution - <<(forall x. P(x) ==> (exists y. G(y) /\ H(x,y)) /\ - (exists y. G(y) /\ ~H(x,y))) /\ - (exists x. J(x) /\ (forall y. G(y) ==> H(x,y))) ==> - (exists x. J(x) /\ ~P(x))>>;; - -{- ** and this... - -let p45 = time presolution - <<(forall x. - P(x) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y)) ==> - (forall y. G(y) /\ H(x,y) ==> R(y))) /\ - ~(exists y. L(y) /\ R(y)) /\ - (exists x. P(x) /\ (forall y. H(x,y) ==> - L(y)) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y))) ==> - (exists x. P(x) /\ ~(exists y. G(y) /\ H(x,y)))>>;; - - ** -} - -{- ** and this - -let p46 = time presolution - <<(forall x. P(x) /\ (forall y. P(y) /\ H(y,x) ==> G(y)) ==> G(x)) /\ - ((exists x. P(x) /\ ~G(x)) ==> - (exists x. P(x) /\ ~G(x) /\ - (forall y. P(y) /\ ~G(y) ==> J(x,y)))) /\ - (forall x y. P(x) /\ P(y) /\ H(x,y) ==> ~J(y,x)) ==> - (forall x. P(x) ==> G(x))>>;; - - ** -} - --- ------------------------------------------------------------------------- --- Example from Manthey and Bry, CADE-9. --- ------------------------------------------------------------------------- - -let p55 = time presolution - < hates(x,y) /\ ~richer(x,y)) /\ - (forall x. hates(agatha,x) ==> ~hates(charles,x)) /\ - (hates(agatha,agatha) /\ hates(agatha,charles)) /\ - (forall x. lives(x) /\ ~richer(x,agatha) ==> hates(butler,x)) /\ - (forall x. hates(agatha,x) ==> hates(butler,x)) /\ - (forall x. ~hates(x,agatha) \/ ~hates(x,butler) \/ ~hates(x,charles)) - ==> killed(agatha,agatha) /\ - ~killed(butler,agatha) /\ - ~killed(charles,agatha)>>;; - -let p57 = time presolution - < P(x,z)) - ==> P(f(a,b),f(a,c))>>;; - --- ------------------------------------------------------------------------- --- See info-hol, circa 1500. --- ------------------------------------------------------------------------- - -let p58 = time presolution - < ((P(v) \/ R(w)) /\ (R(z) ==> Q(v))))>>;; - -let p59 = time presolution - <<(forall x. P(x) <=> ~P(f(x))) ==> (exists x. P(x) /\ ~P(f(x)))>>;; - -let p60 = time presolution - < - exists y. (forall z. P(z,y) ==> P(z,f(x))) /\ P(x,y)>>;; - --- ------------------------------------------------------------------------- --- From Gilmore's classic paper. --- ------------------------------------------------------------------------- - -let gilmore_1 = time presolution - < G(y)) <=> F(x)) /\ - ((F(y) ==> H(y)) <=> G(x)) /\ - (((F(y) ==> G(y)) ==> H(y)) <=> H(x)) - ==> F(z) /\ G(z) /\ H(z)>>;; - -{- ** This is not valid, according to Gilmore - -let gilmore_2 = time presolution - < F(z,y)) /\ (F(z,y) <=> F(z,z)) /\ (F(x,y) <=> F(y,x)) - ==> (F(x,y) <=> F(x,z))>>;; - - ** -} - -let gilmore_3 = time presolution - < (G(y) ==> H(x))) ==> F(x,x)) /\ - ((F(z,x) ==> G(x)) ==> H(z)) /\ - F(x,y) - ==> F(z,z)>>;; - -let gilmore_4 = time presolution - < F(y,z) /\ F(z,z)) /\ - (F(x,y) /\ G(x,y) ==> G(x,z) /\ G(z,z))>>;; - -let gilmore_5 = time presolution - <<(forall x. exists y. F(x,y) \/ F(y,x)) /\ - (forall x y. F(y,x) ==> F(y,y)) - ==> exists z. F(z,z)>>;; - -let gilmore_6 = time presolution - < G(v,u) /\ G(u,x)) - ==> (exists u. forall v. F(u,y) ==> G(v,u) /\ G(u,y)) \/ - (forall u v. exists w. G(v,u) \/ H(w,y,u) ==> G(u,w))>>;; - -let gilmore_7 = time presolution - <<(forall x. K(x) ==> exists y. L(y) /\ (F(x,y) ==> G(x,y))) /\ - (exists z. K(z) /\ forall u. L(u) ==> F(z,u)) - ==> exists v w. K(v) /\ L(w) /\ G(v,w)>>;; - -let gilmore_8 = time presolution - < (G(y) ==> (forall u. exists v. H(u,v,x)))) ==> F(x,x)) /\ - ((F(z,x) ==> G(x)) ==> (forall u. exists v. H(u,v,z))) /\ - F(x,y) - ==> F(z,z)>>;; - -{- ** This one still isn't easy! - -let gilmore_9 = time presolution - < (forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z)) - ==> (forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y))) /\ - ((forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y)) - ==> ~(forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z)) - ==> (forall u. exists v. F(y,u,v) /\ G(y,u) /\ ~H(y,x)) /\ - (forall u. exists v. F(z,u,v) /\ G(y,u) /\ ~H(z,y)))>>;; - - ** -} - --- ------------------------------------------------------------------------- --- Example from Davis-Putnam papers where Gilmore procedure is poor. --- ------------------------------------------------------------------------- - -let davis_putnam_example = time presolution - < (F(y,z) /\ F(z,z))) /\ - ((F(x,y) /\ G(x,y)) ==> (G(x,z) /\ G(z,z)))>>;; - -*********** -} -END_INTERACTIVE;; - --- ------------------------------------------------------------------------- --- Example --- ------------------------------------------------------------------------- - -START_INTERACTIVE;; -let gilmore_1 = resolution - < G(y)) <=> F(x)) /\ - ((F(y) ==> H(y)) <=> G(x)) /\ - (((F(y) ==> G(y)) ==> H(y)) <=> H(x)) - ==> F(z) /\ G(z) /\ H(z)>>;; - --- ------------------------------------------------------------------------- --- Pelletiers yet again. --- ------------------------------------------------------------------------- - -{- ************ - -let p1 = time resolution - <

q <=> ~q ==> ~p>>;; - -let p2 = time resolution - <<~ ~p <=> p>>;; - -let p3 = time resolution - <<~(p ==> q) ==> q ==> p>>;; - -let p4 = time resolution - <<~p ==> q <=> ~q ==> p>>;; - -let p5 = time resolution - <<(p \/ q ==> p \/ r) ==> p \/ (q ==> r)>>;; - -let p6 = time resolution - <

>;; - -let p7 = time resolution - <

>;; - -let p8 = time resolution - <<((p ==> q) ==> p) ==> p>>;; - -let p9 = time resolution - <<(p \/ q) /\ (~p \/ q) /\ (p \/ ~q) ==> ~(~q \/ ~q)>>;; - -let p10 = time resolution - <<(q ==> r) /\ (r ==> p /\ q) /\ (p ==> q /\ r) ==> (p <=> q)>>;; - -let p11 = time resolution - <

p>>;; - -let p12 = time resolution - <<((p <=> q) <=> r) <=> (p <=> (q <=> r))>>;; - -let p13 = time resolution - <

(p \/ q) /\ (p \/ r)>>;; - -let p14 = time resolution - <<(p <=> q) <=> (q \/ ~p) /\ (~q \/ p)>>;; - -let p15 = time resolution - <

q <=> ~p \/ q>>;; - -let p16 = time resolution - <<(p ==> q) \/ (q ==> p)>>;; - -let p17 = time resolution - <

r) ==> s <=> (~p \/ q \/ s) /\ (~p \/ ~r \/ s)>>;; - -(* ------------------------------------------------------------------------- *) -(* Monadic Predicate Logic. *) -(* ------------------------------------------------------------------------- *) - -let p18 = time resolution - < P(x)>>;; - -let p19 = time resolution - < Q(z)) ==> P(x) ==> Q(x)>>;; - -let p20 = time resolution - <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w)) ==> - (exists x y. P(x) /\ Q(y)) ==> - (exists z. R(z))>>;; - -let p21 = time resolution - <<(exists x. P ==> Q(x)) /\ (exists x. Q(x) ==> P) ==> (exists x. P <=> Q(x))>>;; - -let p22 = time resolution - <<(forall x. P <=> Q(x)) ==> (P <=> (forall x. Q(x)))>>;; - -let p23 = time resolution - <<(forall x. P \/ Q(x)) <=> P \/ (forall x. Q(x))>>;; - -let p24 = time resolution - <<~(exists x. U(x) /\ Q(x)) /\ - (forall x. P(x) ==> Q(x) \/ R(x)) /\ - ~(exists x. P(x) ==> (exists x. Q(x))) /\ - (forall x. Q(x) /\ R(x) ==> U(x)) ==> - (exists x. P(x) /\ R(x))>>;; - -let p25 = time resolution - <<(exists x. P(x)) /\ - (forall x. U(x) ==> ~G(x) /\ R(x)) /\ - (forall x. P(x) ==> G(x) /\ U(x)) /\ - ((forall x. P(x) ==> Q(x)) \/ (exists x. Q(x) /\ P(x))) ==> - (exists x. Q(x) /\ P(x))>>;; - -let p26 = time resolution - <<((exists x. P(x)) <=> (exists x. Q(x))) /\ - (forall x y. P(x) /\ Q(y) ==> (R(x) <=> U(y))) ==> - ((forall x. P(x) ==> R(x)) <=> (forall x. Q(x) ==> U(x)))>>;; - -let p27 = time resolution - <<(exists x. P(x) /\ ~Q(x)) /\ - (forall x. P(x) ==> R(x)) /\ - (forall x. U(x) /\ V(x) ==> P(x)) /\ - (exists x. R(x) /\ ~Q(x)) ==> - (forall x. U(x) ==> ~R(x)) ==> - (forall x. U(x) ==> ~V(x))>>;; - -let p28 = time resolution - <<(forall x. P(x) ==> (forall x. Q(x))) /\ - ((forall x. Q(x) \/ R(x)) ==> (exists x. Q(x) /\ R(x))) /\ - ((exists x. R(x)) ==> (forall x. L(x) ==> M(x))) ==> - (forall x. P(x) /\ L(x) ==> M(x))>>;; - -let p29 = time resolution - <<(exists x. P(x)) /\ (exists x. G(x)) ==> - ((forall x. P(x) ==> H(x)) /\ (forall x. G(x) ==> J(x)) <=> - (forall x y. P(x) /\ G(y) ==> H(x) /\ J(y)))>>;; - -let p30 = time resolution - <<(forall x. P(x) \/ G(x) ==> ~H(x)) /\ (forall x. (G(x) ==> ~U(x)) ==> - P(x) /\ H(x)) ==> - (forall x. U(x))>>;; - -let p31 = time resolution - <<~(exists x. P(x) /\ (G(x) \/ H(x))) /\ (exists x. Q(x) /\ P(x)) /\ - (forall x. ~H(x) ==> J(x)) ==> - (exists x. Q(x) /\ J(x))>>;; - -let p32 = time resolution - <<(forall x. P(x) /\ (G(x) \/ H(x)) ==> Q(x)) /\ - (forall x. Q(x) /\ H(x) ==> J(x)) /\ - (forall x. R(x) ==> H(x)) ==> - (forall x. P(x) /\ R(x) ==> J(x))>>;; - -let p33 = time resolution - <<(forall x. P(a) /\ (P(x) ==> P(b)) ==> P(c)) <=> - (forall x. P(a) ==> P(x) \/ P(c)) /\ (P(a) ==> P(b) ==> P(c))>>;; - -let p34 = time resolution - <<((exists x. forall y. P(x) <=> P(y)) <=> - ((exists x. Q(x)) <=> (forall y. Q(y)))) <=> - ((exists x. forall y. Q(x) <=> Q(y)) <=> - ((exists x. P(x)) <=> (forall y. P(y))))>>;; - -let p35 = time resolution - < (forall x y. P(x,y))>>;; - -(* ------------------------------------------------------------------------- *) -(* Full predicate logic (without Identity and Functions) *) -(* ------------------------------------------------------------------------- *) - -let p36 = time resolution - <<(forall x. exists y. P(x,y)) /\ - (forall x. exists y. G(x,y)) /\ - (forall x y. P(x,y) \/ G(x,y) - ==> (forall z. P(y,z) \/ G(y,z) ==> H(x,z))) - ==> (forall x. exists y. H(x,y))>>;; - -let p37 = time resolution - <<(forall z. - exists w. forall x. exists y. (P(x,z) ==> P(y,w)) /\ P(y,z) /\ - (P(y,w) ==> (exists u. Q(u,w)))) /\ - (forall x z. ~P(x,z) ==> (exists y. Q(y,z))) /\ - ((exists x y. Q(x,y)) ==> (forall x. R(x,x))) ==> - (forall x. exists y. R(x,y))>>;; - -(*** This one seems too slow - -let p38 = time resolution - <<(forall x. - P(a) /\ (P(x) ==> (exists y. P(y) /\ R(x,y))) ==> - (exists z w. P(z) /\ R(x,w) /\ R(w,z))) <=> - (forall x. - (~P(a) \/ P(x) \/ (exists z w. P(z) /\ R(x,w) /\ R(w,z))) /\ - (~P(a) \/ ~(exists y. P(y) /\ R(x,y)) \/ - (exists z w. P(z) /\ R(x,w) /\ R(w,z))))>>;; - - ***) - -let p39 = time resolution - <<~(exists x. forall y. P(y,x) <=> ~P(y,y))>>;; - -let p40 = time resolution - <<(exists y. forall x. P(x,y) <=> P(x,x)) - ==> ~(forall x. exists y. forall z. P(z,y) <=> ~P(z,x))>>;; - -let p41 = time resolution - <<(forall z. exists y. forall x. P(x,y) <=> P(x,z) /\ ~P(x,x)) - ==> ~(exists z. forall x. P(x,z))>>;; - -(*** Also very slow - -let p42 = time resolution - <<~(exists y. forall x. P(x,y) <=> ~(exists z. P(x,z) /\ P(z,x)))>>;; - - ***) - -(*** and this one too.. - -let p43 = time resolution - <<(forall x y. Q(x,y) <=> forall z. P(z,x) <=> P(z,y)) - ==> forall x y. Q(x,y) <=> Q(y,x)>>;; - - ***) - -let p44 = time resolution - <<(forall x. P(x) ==> (exists y. G(y) /\ H(x,y)) /\ - (exists y. G(y) /\ ~H(x,y))) /\ - (exists x. J(x) /\ (forall y. G(y) ==> H(x,y))) ==> - (exists x. J(x) /\ ~P(x))>>;; - -(*** and this... - -let p45 = time resolution - <<(forall x. - P(x) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y)) ==> - (forall y. G(y) /\ H(x,y) ==> R(y))) /\ - ~(exists y. L(y) /\ R(y)) /\ - (exists x. P(x) /\ (forall y. H(x,y) ==> - L(y)) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y))) ==> - (exists x. P(x) /\ ~(exists y. G(y) /\ H(x,y)))>>;; - - ***) - -(*** and this - -let p46 = time resolution - <<(forall x. P(x) /\ (forall y. P(y) /\ H(y,x) ==> G(y)) ==> G(x)) /\ - ((exists x. P(x) /\ ~G(x)) ==> - (exists x. P(x) /\ ~G(x) /\ - (forall y. P(y) /\ ~G(y) ==> J(x,y)))) /\ - (forall x y. P(x) /\ P(y) /\ H(x,y) ==> ~J(y,x)) ==> - (forall x. P(x) ==> G(x))>>;; - - ***) - -(* ------------------------------------------------------------------------- *) -(* Example from Manthey and Bry, CADE-9. *) -(* ------------------------------------------------------------------------- *) - -let p55 = time resolution - < hates(x,y) /\ ~richer(x,y)) /\ - (forall x. hates(agatha,x) ==> ~hates(charles,x)) /\ - (hates(agatha,agatha) /\ hates(agatha,charles)) /\ - (forall x. lives(x) /\ ~richer(x,agatha) ==> hates(butler,x)) /\ - (forall x. hates(agatha,x) ==> hates(butler,x)) /\ - (forall x. ~hates(x,agatha) \/ ~hates(x,butler) \/ ~hates(x,charles)) - ==> killed(agatha,agatha) /\ - ~killed(butler,agatha) /\ - ~killed(charles,agatha)>>;; - -let p57 = time resolution - < P(x,z)) - ==> P(f(a,b),f(a,c))>>;; - -(* ------------------------------------------------------------------------- *) -(* See info-hol, circa 1500. *) -(* ------------------------------------------------------------------------- *) - -let p58 = time resolution - < ((P(v) \/ R(w)) /\ (R(z) ==> Q(v))))>>;; - -let p59 = time resolution - <<(forall x. P(x) <=> ~P(f(x))) ==> (exists x. P(x) /\ ~P(f(x)))>>;; - -let p60 = time resolution - < - exists y. (forall z. P(z,y) ==> P(z,f(x))) /\ P(x,y)>>;; - -(* ------------------------------------------------------------------------- *) -(* From Gilmore's classic paper. *) -(* ------------------------------------------------------------------------- *) - -let gilmore_1 = time resolution - < G(y)) <=> F(x)) /\ - ((F(y) ==> H(y)) <=> G(x)) /\ - (((F(y) ==> G(y)) ==> H(y)) <=> H(x)) - ==> F(z) /\ G(z) /\ H(z)>>;; - -(*** This is not valid, according to Gilmore - -let gilmore_2 = time resolution - < F(z,y)) /\ (F(z,y) <=> F(z,z)) /\ (F(x,y) <=> F(y,x)) - ==> (F(x,y) <=> F(x,z))>>;; - - ***) - -let gilmore_3 = time resolution - < (G(y) ==> H(x))) ==> F(x,x)) /\ - ((F(z,x) ==> G(x)) ==> H(z)) /\ - F(x,y) - ==> F(z,z)>>;; - -let gilmore_4 = time resolution - < F(y,z) /\ F(z,z)) /\ - (F(x,y) /\ G(x,y) ==> G(x,z) /\ G(z,z))>>;; - -let gilmore_5 = time resolution - <<(forall x. exists y. F(x,y) \/ F(y,x)) /\ - (forall x y. F(y,x) ==> F(y,y)) - ==> exists z. F(z,z)>>;; - -let gilmore_6 = time resolution - < G(v,u) /\ G(u,x)) - ==> (exists u. forall v. F(u,y) ==> G(v,u) /\ G(u,y)) \/ - (forall u v. exists w. G(v,u) \/ H(w,y,u) ==> G(u,w))>>;; - -let gilmore_7 = time resolution - <<(forall x. K(x) ==> exists y. L(y) /\ (F(x,y) ==> G(x,y))) /\ - (exists z. K(z) /\ forall u. L(u) ==> F(z,u)) - ==> exists v w. K(v) /\ L(w) /\ G(v,w)>>;; - -let gilmore_8 = time resolution - < (G(y) ==> (forall u. exists v. H(u,v,x)))) ==> F(x,x)) /\ - ((F(z,x) ==> G(x)) ==> (forall u. exists v. H(u,v,z))) /\ - F(x,y) - ==> F(z,z)>>;; - -(*** This one still isn't easy! - -let gilmore_9 = time resolution - < (forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z)) - ==> (forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y))) /\ - ((forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y)) - ==> ~(forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z)) - ==> (forall u. exists v. F(y,u,v) /\ G(y,u) /\ ~H(y,x)) /\ - (forall u. exists v. F(z,u,v) /\ G(y,u) /\ ~H(z,y)))>>;; - - ***) - -(* ------------------------------------------------------------------------- *) -(* Example from Davis-Putnam papers where Gilmore procedure is poor. *) -(* ------------------------------------------------------------------------- *) - -let davis_putnam_example = time resolution - < (F(y,z) /\ F(z,z))) /\ - ((F(x,y) /\ G(x,y)) ==> (G(x,z) /\ G(z,z)))>>;; - -(* ------------------------------------------------------------------------- *) -(* The (in)famous Los problem. *) -(* ------------------------------------------------------------------------- *) - -let los = time resolution - <<(forall x y z. P(x,y) ==> P(y,z) ==> P(x,z)) /\ - (forall x y z. Q(x,y) ==> Q(y,z) ==> Q(x,z)) /\ - (forall x y. Q(x,y) ==> Q(y,x)) /\ - (forall x y. P(x,y) \/ Q(x,y)) - ==> (forall x y. P(x,y)) \/ (forall x y. Q(x,y))>>;; - -************* -} -END_INTERACTIVE;; --} diff --git a/Data/Logic/Harrison/Skolem.hs b/Data/Logic/Harrison/Skolem.hs deleted file mode 100644 --- a/Data/Logic/Harrison/Skolem.hs +++ /dev/null @@ -1,355 +0,0 @@ -{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies #-} -{-# OPTIONS_GHC -Wall #-} -module Data.Logic.Harrison.Skolem - ( simplify - -- , simplify' - , lsimplify - , nnf - -- , nnf' - , pnf - -- , pnf' - , functions - -- , functions' - , SkolemT - , Skolem - , runSkolem - , runSkolemT - , specialize - , skolemize - -- , literal - , askolemize - , skolemNormalForm - -- , prenex' - , skolem - ) where - -import Control.Monad.Identity (Identity(runIdentity)) -import Control.Monad.State (StateT(runStateT)) -import Data.Logic.Classes.Atom (Atom) -import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..), binop) -import Data.Logic.Classes.Constants (Constants(fromBool, asBool), true, false) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(exists, for_all, foldFirstOrder), Quant(..), quant, toPropositional) -import Data.Logic.Classes.Formula (Formula(..)) -import Data.Logic.Classes.Literal (Literal(foldLiteral)) -import Data.Logic.Classes.Negate ((.~.)) -import Data.Logic.Classes.Propositional (PropositionalFormula(..)) -import qualified Data.Logic.Classes.Skolem as C -import Data.Logic.Classes.Term (Term(..)) -import Data.Logic.Classes.Variable (Variable(variant)) -import Data.Logic.Harrison.FOL (fv, subst) -import Data.Logic.Harrison.Lib ((|=>)) -import qualified Data.Map as Map -import qualified Data.Set as Set - --- ========================================================================= --- Prenex and Skolem normal forms. --- --- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) --- ========================================================================= - --- ------------------------------------------------------------------------- --- Routine simplification. Like "psimplify" but with quantifier clauses. --- ------------------------------------------------------------------------- - -simplify1 :: (FirstOrderFormula fof atom v, - -- Formula fof term v, - Atom atom term v, - Term term v f) => fof -> fof -simplify1 fm = - foldFirstOrder qu co tf at fm - where - qu _ x p = if Set.member x (fv p) then fm else p - co ((:~:) p) = foldFirstOrder (\ _ _ _ -> fm) nco (fromBool . not) (\ _ -> fm) p - co (BinOp l op r) = simplifyBinop l op r - nco ((:~:) p) = p - nco _ = fm - tf = fromBool - at _ = fm - -simplifyBinop :: forall p. (Constants p, Combinable p) => p -> BinOp -> p -> p -simplifyBinop l op r = - case (asBool l, op, asBool r) of - (Just True, (:&:), _ ) -> r - (Just False, (:&:), _ ) -> false - (_, (:&:), Just True ) -> l - (_, (:&:), Just False) -> false - (Just True, (:|:), _ ) -> true - (Just False, (:|:), _ ) -> r - (_, (:|:), Just True ) -> true - (_, (:|:), Just False) -> l - (Just True, (:=>:), _ ) -> r - (Just False, (:=>:), _ ) -> true - (_, (:=>:), Just True ) -> true - (_, (:=>:), Just False) -> (.~.) l - (Just False, (:<=>:), Just False) -> true - (Just True, (:<=>:), _ ) -> r - (Just False, (:<=>:), _ ) -> (.~.) r - (_, (:<=>:), Just True ) -> l - (_, (:<=>:), Just False) -> (.~.) l - _ -> binop l op r - -simplify :: (FirstOrderFormula fof atom v, - Atom atom term v, - Term term v f) => fof -> fof -simplify fm = - foldFirstOrder qu co tf at fm - where - qu op x fm' = simplify1 (quant op x (simplify fm')) - co ((:~:) fm') = simplify1 ((.~.) (simplify fm')) - co (BinOp fm1 op fm2) = simplify1 (binop (simplify fm1) op (simplify fm2)) - tf = fromBool - at _ = fm - --- | Just looks for double negatives and negated constants. -lsimplify :: Literal lit atom => lit -> lit -lsimplify fm = foldLiteral (lsimplify1 . (.~.) . lsimplify) fromBool (const fm) fm - -lsimplify1 :: Literal lit atom => lit -> lit -lsimplify1 fm = foldLiteral (foldLiteral id (fromBool . not) (const fm)) fromBool (const fm) fm - - --- ------------------------------------------------------------------------- --- Negation normal form. --- ------------------------------------------------------------------------- - -nnf :: FirstOrderFormula formula atom v => formula -> formula -nnf fm = - foldFirstOrder nnfQuant nnfCombine (\ _ -> fm) (\ _ -> fm) fm - where - nnfQuant op v p = quant op v (nnf p) - nnfCombine ((:~:) p) = foldFirstOrder nnfNotQuant nnfNotCombine (fromBool . not) (\ _ -> fm) p - nnfCombine (BinOp p (:=>:) q) = nnf ((.~.) p) .|. (nnf q) - nnfCombine (BinOp p (:<=>:) q) = (nnf p .&. nnf q) .|. (nnf ((.~.) p) .&. nnf ((.~.) q)) - nnfCombine (BinOp p (:&:) q) = nnf p .&. nnf q - nnfCombine (BinOp p (:|:) q) = nnf p .|. nnf q - nnfNotQuant Forall v p = exists v (nnf ((.~.) p)) - nnfNotQuant Exists v p = for_all v (nnf ((.~.) p)) - nnfNotCombine ((:~:) p) = nnf p - nnfNotCombine (BinOp p (:&:) q) = nnf ((.~.) p) .|. nnf ((.~.) q) - nnfNotCombine (BinOp p (:|:) q) = nnf ((.~.) p) .&. nnf ((.~.) q) - nnfNotCombine (BinOp p (:=>:) q) = nnf p .&. nnf ((.~.) q) - nnfNotCombine (BinOp p (:<=>:) q) = (nnf p .&. nnf ((.~.) q)) .|. nnf ((.~.) p) .&. nnf q - --- ------------------------------------------------------------------------- --- Prenex normal form. --- ------------------------------------------------------------------------- - -pullQuants :: forall formula atom v term f. (FirstOrderFormula formula atom v, {-Formula formula term v,-} Atom atom term v, Term term v f) => - formula -> formula -pullQuants fm = - foldFirstOrder (\ _ _ _ -> fm) pullQuantsCombine (\ _ -> fm) (\ _ -> fm) fm - where - getQuant = foldFirstOrder (\ op v f -> Just (op, v, f)) (\ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) - pullQuantsCombine ((:~:) _) = fm - pullQuantsCombine (BinOp l op r) = - case (getQuant l, op, getQuant r) of - (Just (Forall, vl, l'), (:&:), Just (Forall, vr, r')) -> pullq True True fm for_all (.&.) vl vr l' r' - (Just (Exists, vl, l'), (:|:), Just (Exists, vr, r')) -> pullq True True fm exists (.|.) vl vr l' r' - (Just (Forall, vl, l'), (:&:), _) -> pullq True False fm for_all (.&.) vl vl l' r - (_, (:&:), Just (Forall, vr, r')) -> pullq False True fm for_all (.&.) vr vr l r' - (Just (Forall, vl, l'), (:|:), _) -> pullq True False fm for_all (.|.) vl vl l' r - (_, (:|:), Just (Forall, vr, r')) -> pullq False True fm for_all (.|.) vr vr l r' - (Just (Exists, vl, l'), (:&:), _) -> pullq True False fm exists (.&.) vl vl l' r - (_, (:&:), Just (Exists, vr, r')) -> pullq False True fm exists (.&.) vr vr l r' - (Just (Exists, vl, l'), (:|:), _) -> pullq True False fm exists (.|.) vl vl l' r - (_, (:|:), Just (Exists, vr, r')) -> pullq False True fm exists (.|.) vr vr l r' - _ -> fm - --- |Helper function to rename variables when we want to enclose a --- formula containing a free occurrence of that variable a quantifier --- that quantifies it. -pullq :: (FirstOrderFormula formula atom v, Atom atom term v, Term term v f) => - Bool -> Bool - -> formula - -> (v -> formula -> formula) - -> (formula -> formula -> formula) - -> v -> v - -> formula -> formula - -> formula -pullq l r fm mkq op x y p q = - let z = variant x (fv fm) - p' = if l then subst (x |=> vt z) p else p - q' = if r then subst (y |=> vt z) q else q - fm' = pullQuants (op p' q') in - mkq z fm' - --- |Recursivly apply pullQuants anywhere a quantifier might not be --- leftmost. -prenex :: (FirstOrderFormula formula atom v, {-Formula formula term v,-} Atom atom term v, Term term v f) => - formula -> formula -prenex fm = - foldFirstOrder qu co (\ _ -> fm) (\ _ -> fm) fm - where - qu op x p = quant op x (prenex p) - co (BinOp l (:&:) r) = pullQuants (prenex l .&. prenex r) - co (BinOp l (:|:) r) = pullQuants (prenex l .|. prenex r) - co _ = fm - --- |Convert to Prenex normal form, with all quantifiers at the left. -pnf :: (FirstOrderFormula formula atom v, Atom atom term v, Term term v f) => formula -> formula -pnf = prenex . nnf . simplify - --- ------------------------------------------------------------------------- --- Get the functions in a term and formula. --- ------------------------------------------------------------------------- - --- FIXME: the function parameter should be a method in the Atom class, --- but we need to add a type parameter f to it first. -functions :: forall formula atom f. (Formula formula atom, Ord f) => (atom -> Set.Set (f, Int)) -> formula -> Set.Set (f, Int) -functions fa fm = foldAtoms (\ s a -> Set.union s (fa a)) Set.empty fm - --- ------------------------------------------------------------------------- --- State monad for generating Skolem functions and constants. --- ------------------------------------------------------------------------- - --- | Harrison's code generated skolem functions by adding a prefix to --- the variable name they are based on. Here we have a more general --- and type safe solution: we require that variables be instances of --- class Skolem which creates Skolem functions based on an integer. --- This state value exists in the SkolemT monad during skolemization --- and tracks the next available number and the current list of --- universally quantified variables. - -data SkolemState v term - = SkolemState - { skolemCount :: Int - -- ^ The next available Skolem number. - , univQuant :: [v] - -- ^ The variables which are universally quantified in the - -- current scope, in the order they were encountered. During - -- Skolemization these are the parameters passed to the Skolem - -- function. - } - --- | The state associated with the Skolem monad. -newSkolemState :: SkolemState v term -newSkolemState - = SkolemState - { skolemCount = 1 - , univQuant = [] - } - --- | The Skolem monad transformer -type SkolemT v term m = StateT (SkolemState v term) m - --- | Run a computation in the Skolem monad. -runSkolem :: SkolemT v term Identity a -> a -runSkolem = runIdentity . runSkolemT - --- | The Skolem monad -type Skolem v term = StateT (SkolemState v term) Identity - --- | Run a computation in a stacked invocation of the Skolem monad. -runSkolemT :: Monad m => SkolemT v term m a -> m a -runSkolemT action = (runStateT action) newSkolemState >>= return . fst - --- ------------------------------------------------------------------------- --- Core Skolemization function. --- ------------------------------------------------------------------------- - --- |Skolemize the formula by removing the existential quantifiers and --- replacing the variables they quantify with skolem functions (and --- constants, which are functions of zero variables.) The Skolem --- functions are new functions (obtained from the SkolemT monad) which --- are applied to the list of variables which are universally --- quantified in the context where the existential quantifier --- appeared. -skolem :: (Monad m, - FirstOrderFormula fof atom v, - -- PropositionalFormula pf atom, - -- Formula formula term v, - Atom atom term v, - Term term v f) => - fof -> SkolemT v term m fof -skolem fm = - foldFirstOrder qu co (return . fromBool) (return . atomic) fm - where - -- We encountered an existentially quantified variable y, - -- allocate a new skolem function fx and do a substitution to - -- replace occurrences of y with fx. The value of the Skolem - -- function is assumed to equal the value of y which satisfies - -- the formula. - qu Exists y p = - do let xs = fv fm - let fx = fApp (C.toSkolem y) (map vt (Set.toAscList xs)) - skolem (subst (Map.singleton y fx) p) - qu Forall x p = skolem p >>= return . for_all x - co (BinOp l (:&:) r) = skolem2 (.&.) l r - co (BinOp l (:|:) r) = skolem2 (.|.) l r - co _ = return fm - -skolem2 :: (Monad m, - FirstOrderFormula fof atom v, - -- PropositionalFormula pf atom, - -- Formula formula term v, - Atom atom term v, - Term term v f) => - (fof -> fof -> fof) -> fof -> fof -> SkolemT v term m fof -skolem2 cons p q = - skolem p >>= \ p' -> - skolem q >>= \ q' -> - return (cons p' q') - --- ------------------------------------------------------------------------- --- Overall Skolemization function. --- ------------------------------------------------------------------------- - --- |I need to consult the Harrison book for the reasons why we don't --- |just Skolemize the result of prenexNormalForm. -askolemize :: forall m fof atom term v f. - (Monad m, - FirstOrderFormula fof atom v, - Atom atom term v, - Term term v f) => - fof -> SkolemT v term m fof -askolemize = skolem . nnf . simplify - --- | Remove the leading universal quantifiers. After a call to pnf --- this will be all the universal quantifiers, and the skolemization --- will have already turned all the existential quantifiers into --- skolem functions. -specialize :: forall fof atom v. FirstOrderFormula fof atom v => fof -> fof -specialize f = - foldFirstOrder q (\ _ -> f) (\ _ -> f) (\ _ -> f) f - where - q Forall _ f' = specialize f' - q _ _ _ = f - --- | Skolemize and then specialize. Because we know all quantifiers --- are gone we can convert to any instance of PropositionalFormula. -skolemize :: forall m fof atom term v f pf atom2. (Monad m, - FirstOrderFormula fof atom v, - PropositionalFormula pf atom2, - Atom atom term v, - Term term v f, - Eq pf) => - (atom -> atom2) -> fof -> SkolemT v term m pf -skolemize ca fm = askolemize fm >>= return . (toPropositional ca :: fof -> pf) . specialize . pnf - -{- --- | Convert a first order formula into a disjunct of conjuncts of --- literals. Note that this can convert any instance of --- FirstOrderFormula into any instance of Literal. -literal :: forall fof atom term v p f lit. (Literal fof atom, Apply atom p term, Term term v f, Literal lit atom, Formula lit atom, Ord lit) => - fof -> Set.Set (Set.Set lit) -literal fm = - foldLiteral neg tf at fm - where - neg :: fof -> Set.Set (Set.Set lit) - neg x = Set.map (Set.map (.~.)) (literal x) - tf = Set.singleton . Set.singleton . fromBool - at :: atom -> Set.Set (Set.Set lit) - at x = foldApply (\ _ _ -> Set.singleton (Set.singleton (atomic x))) tf x --} - --- |We get Skolem Normal Form by skolemizing and then converting to --- Prenex Normal Form, and finally eliminating the remaining quantifiers. -skolemNormalForm :: (FirstOrderFormula fof atom v, - PropositionalFormula pf atom2, - -- Formula fof term v, - -- Formula pf term v, - Atom atom term v, - Term term v f, - Monad m, Ord fof, Eq pf) => - (atom -> atom2) -> fof -> SkolemT v term m pf -skolemNormalForm = skolemize diff --git a/Data/Logic/Harrison/Tableaux.hs b/Data/Logic/Harrison/Tableaux.hs deleted file mode 100644 --- a/Data/Logic/Harrison/Tableaux.hs +++ /dev/null @@ -1,629 +0,0 @@ -{-# LANGUAGE CPP, NoMonomorphismRestriction, OverloadedStrings, RankNTypes, ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} -module Data.Logic.Harrison.Tableaux - ( unify_literals - , unifyAtomsEq - , deepen - ) where - -import Control.Applicative.Error (Failing(..)) ---import Data.List (partition) -import qualified Data.Logic.Classes.Atom as C ---import Data.Logic.Classes.Combine ((.&.), (.=>.)) ---import Data.Logic.Classes.Constants (false) -import Data.Logic.Classes.Equals (AtomEq, zipAtomsEq) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula, exists, for_all) -import Data.Logic.Classes.Formula (Formula(..)) -import Data.Logic.Classes.Negate (positive, (.~.)) -import Data.Logic.Classes.Literal (Literal, zipLiterals) -import Data.Logic.Classes.Propositional (PropositionalFormula) -import Data.Logic.Classes.Term (Term(..), vt) -import Data.Logic.Harrison.FOL (subst, generalize) -import Data.Logic.Harrison.Herbrand (davisputnam) -import Data.Logic.Harrison.Lib (allpairs, settryfind, distrib') -import Data.Logic.Harrison.Prop (simpdnf) -import Data.Logic.Harrison.Skolem (runSkolem, skolemize) -import Data.Logic.Harrison.Unif (unify) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.String (IsString(..)) -import Debug.Trace (trace) - --- ========================================================================= --- Tableaux, seen as an optimized version of a Prawitz-like procedure. --- --- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) --- ========================================================================= - --- ------------------------------------------------------------------------- --- Unify literals (just pretend the toplevel relation is a function). --- ------------------------------------------------------------------------- - -unify_literals :: forall lit atom term v f. - (Literal lit atom, - C.Atom atom term v, - Term term v f) => - Map.Map v term -> lit -> lit -> Failing (Map.Map v term) -unify_literals env f1 f2 = - maybe err id (zipLiterals co tf at f1 f2) - where - -- co :: lit -> lit -> Maybe (Failing (Map.Map v term)) - co p q = Just $ unify_literals env p q - tf p q = if p == q then Just $ unify env [] else Nothing - at :: atom -> atom -> Maybe (Failing (Map.Map v term)) - at a1 a2 = Just $ C.unify env a1 a2 - err = Failure ["Can't unify literals"] - -unifyAtomsEq :: forall v f atom p term. - (AtomEq atom p term, Term term v f) => - Map.Map v term -> atom -> atom -> Failing (Map.Map v term) -unifyAtomsEq env a1 a2 = - maybe err id (zipAtomsEq ap tf eq a1 a2) - where - ap p1 ts1 p2 ts2 = - if p1 == p2 && length ts1 == length ts2 - then Just $ unify env (zip ts1 ts2) - else Nothing - tf p q = if p == q then Just $ unify env [] else Nothing - eq pl pr ql qr = Just $ unify env [(pl, ql), (pr, qr)] - err = Failure ["Can't unify atoms"] - --- ------------------------------------------------------------------------- --- Unify complementary literals. --- ------------------------------------------------------------------------- - -unify_complements :: forall lit atom term v f. - (Literal lit atom, - C.Atom atom term v, - Term term v f) => - Map.Map v term -> lit -> lit -> Failing (Map.Map v term) -unify_complements env p q = unify_literals env p ((.~.) q) - --- ------------------------------------------------------------------------- --- Unify and refute a set of disjuncts. --- ------------------------------------------------------------------------- - -unify_refute :: (Literal lit atom, Term term v f, C.Atom atom term v, Ord lit) => Set.Set (Set.Set lit) -> Map.Map v term -> Failing (Map.Map v term) -unify_refute djs env = - case Set.minView djs of - Nothing -> Success env - Just (d, odjs) -> - settryfind (\ (p, n) -> unify_complements env p n >>= unify_refute odjs) pairs - where - pairs = allpairs (,) pos neg - (pos,neg) = Set.partition positive d - --- ------------------------------------------------------------------------- --- Hence a Prawitz-like procedure (using unification on DNF). --- ------------------------------------------------------------------------- - -prawitz_loop :: forall atom v term f lit. (Literal lit atom, Term term v f, C.Atom atom term v, Ord lit) => - Set.Set (Set.Set lit) -> [v] -> Set.Set (Set.Set lit) -> Int -> (Map.Map v term, Int) -prawitz_loop djs0 fvs djs n = - let l = length fvs in - let newvars = map (\ k -> fromString ("_" ++ show (n * l + k))) [1..l] in - let inst = Map.fromList (zip fvs (map vt newvars)) in - let djs1 = distrib' (Set.map (Set.map (mapAtoms (atomic . substitute' inst))) djs0) djs in - case unify_refute djs1 Map.empty of - Failure _ -> prawitz_loop djs0 fvs djs1 (n + 1) - Success env -> (env, n + 1) - where - substitute' :: Map.Map v term -> atom -> atom - substitute' = C.substitute - --- prawitz :: forall fof atom v. (FirstOrderFormula fof atom v, Ord fof) => fof -> Int -#if 0 -prawitz :: forall fof atom term v f lit pf. - (FirstOrderFormula fof atom v, - PropositionalFormula pf atom, - Literal lit atom, - Term term v f, - C.Atom atom term v) => - fof -> Int -prawitz fm = - snd (prawitz_loop dnf (Set.toList fvs) dnf0 0 :: (Map.Map v term, Int)) - where - dnf0 = (Set.singleton Set.empty) :: Set.Set (Set.Set lit) - dnf = simpdnf pf :: Set.Set (Set.Set lit) - fvs = foldAtoms (\ s (a :: atom) -> Set.union (C.freeVariables a) s) Set.empty pf :: Set.Set v - pf = runSkolem (skolemize id ((.~.)(generalize fm))) :: pf -#endif - --- ------------------------------------------------------------------------- --- Examples. --- ------------------------------------------------------------------------- - -{- -test01 = TestCase $ assertEqual "p20 - prawitz" expected input - where input = prawitz fm - fm = (for_all "x" (for_all "y" (exists "z" (for_all "w" (pApp "P" [vt "x"] .&. pApp "Q" [vt "y"] .=>. - pApp "R" [vt "z"] .&. pApp "U" [vt "w"]))))) .=>. - (exists "x" (exists "y" (pApp "P" [vt "x"] .&. pApp "Q" [vt "y"]))) .=>. (exists "z" (pApp "R" [vt "z"])) - expected = 1 --} - --- ------------------------------------------------------------------------- --- Comparison of number of ground instances. --- ------------------------------------------------------------------------- - -{- -compare :: forall fof pf lit atom term v f. - (FirstOrderFormula fof atom v, - PropositionalFormula pf atom, - Literal pf atom, - Term term v f, - C.Atom atom term v, - IsString f) => - (atom -> Set.Set (f, Int)) -> fof -> (Int, Failing Int) --} --- compare fa fm = (prawitz fm, davisputnam fa fm) -{- -START_INTERACTIVE;; -test02 = TestCase $ assertEqual "p19" expected input - where input = compare (exists "x" (forall "y" (for_all "z" ((pApp "P" [vt "y"] .=>. pApp "Q" [vt "z"]) .=>. pApp "P" [vt "x"] .=>. pApp "Q" [vt "x"])))) - -let p20 = compare - <<(forall x y. exists z. forall w. P[vt "x"] .&. Q[vt "y"] .=>. R[vt "z"] .&. U[vt "w"]) - .=>. (exists x y. P[vt "x"] .&. Q[vt "y"]) .=>. (exists z. R[vt "z"])>>;; - -let p24 = compare - <<~(exists x. U[vt "x"] .&. Q[vt "x"]) .&. - (forall x. P[vt "x"] .=>. Q[vt "x"] .|. R[vt "x"]) .&. - ~(exists x. P[vt "x"] .=>. (exists x. Q[vt "x"])) .&. - (forall x. Q[vt "x"] .&. R[vt "x"] .=>. U[vt "x"]) - .=>. (exists x. P[vt "x"] .&. R[vt "x"])>>;; - -let p39 = compare - <<~(exists x. forall y. P(y,x) .<=>. ~P(y,y))>>;; - -let p42 = compare - <<~(exists y. forall x. P(x,y) .<=>. ~(exists z. P(x,z) .&. P(z,x)))>>;; - -{- **** Too slow? - -let p43 = compare - <<(forall x y. Q(x,y) .<=>. forall z. P(z,x) .<=>. P(z,y)) - .=>. forall x y. Q(x,y) .<=>. Q(y,x)>>;; - - ***** -} - -let p44 = compare - <<(forall x. P[vt "x"] .=>. (exists y. G[vt "y"] .&. H(x,y)) .&. - (exists y. G[vt "y"] .&. ~H(x,y))) .&. - (exists x. J[vt "x"] .&. (forall y. G[vt "y"] .=>. H(x,y))) - .=>. (exists x. J[vt "x"] .&. ~P[vt "x"])>>;; - -let p59 = compare - <<(forall x. P[vt "x"] .<=>. ~P(f[vt "x"])) .=>. (exists x. P[vt "x"] .&. ~P(f[vt "x"]))>>;; - -let p60 = compare - <. - exists y. (forall z. P(z,y) .=>. P(z,f[vt "x"])) .&. P(x,y)>>;; - -END_INTERACTIVE;; - --- ------------------------------------------------------------------------- --- More standard tableau procedure, effectively doing DNF incrementally. --- ------------------------------------------------------------------------- - -let rec tableau (fms,lits,n) cont (env,k) = - if n < 0 then error "no proof at this level" else - match fms with - [] -> error "tableau: no proof" - | And(p,q) : unexp -> - tableau (p : q : unexp,lits,n) cont (env,k) - | Or(p,q) : unexp -> - tableau (p : unexp,lits,n) (tableau (q : unexp,lits,n) cont) (env,k) - | Forall(x,p) : unexp -> - let y = Vt("_" ++ string_of_int k) in - let p' = subst (x |=> y) p in - tableau (p' : unexp@[Forall(x,p)],lits,n-1) cont (env,k+1) - | fm : unexp -> - try tryfind (\ l -> cont(unify_complements env (fm,l),k)) lits - with Failure _ -> tableau (unexp,fm : lits,n) cont (env,k);; --} - --- | Try f with higher and higher values of n until it succeeds, or --- optional maximum depth limit is exceeded. -deepen :: (Int -> Failing t) -> Int -> Maybe Int -> Failing (t, Int) -deepen _ n (Just m) | n > m = Failure ["Exceeded maximum depth limit"] -deepen f n m = - -- If no maximum depth limit is given print a trace of the - -- levels tried. The assumption is that we are running - -- interactively. - let n' = maybe (trace ("Searching with depth limit " ++ show n) n) (const n) m in - case f n' of - Failure _ -> deepen f (n + 1) m - Success x -> Success (x, n) - -{- -let tabrefute fms = - deepen (\ n -> tableau (fms,[],n) (\ x -> x) (Map.empty,0); n) 0;; - -let tab fm = - let sfm = askolemize(Not(generalize fm)) in - if sfm = False then 0 else tabrefute [sfm];; - --- ------------------------------------------------------------------------- --- Example. --- ------------------------------------------------------------------------- - -START_INTERACTIVE;; -let p38 = tab - <<(forall x. - P[vt "a"] .&. (P[vt "x"] .=>. (exists y. P[vt "y"] .&. R(x,y))) .=>. - (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))) .<=>. - (forall x. - (~P[vt "a"] .|. P[vt "x"] .|. (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))) .&. - (~P[vt "a"] .|. ~(exists y. P[vt "y"] .&. R(x,y)) .|. - (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))))>>;; -END_INTERACTIVE;; - --- ------------------------------------------------------------------------- --- Try to split up the initial formula first; often a big improvement. --- ------------------------------------------------------------------------- - -let splittab fm = - map tabrefute (simpdnf(askolemize(Not(generalize fm))));; - --- ------------------------------------------------------------------------- --- Example: the Andrews challenge. --- ------------------------------------------------------------------------- - -START_INTERACTIVE;; -let p34 = splittab - <<((exists x. forall y. P[vt "x"] .<=>. P[vt "y"]) .<=>. - ((exists x. Q[vt "x"]) .<=>. (forall y. Q[vt "y"]))) .<=>. - ((exists x. forall y. Q[vt "x"] .<=>. Q[vt "y"]) .<=>. - ((exists x. P[vt "x"]) .<=>. (forall y. P[vt "y"])))>>;; - --- ------------------------------------------------------------------------- --- Another nice example from EWD 1602. --- ------------------------------------------------------------------------- - -let ewd1062 = splittab - <<(forall x. x <= x) .&. - (forall x y z. x <= y .&. y <= z .=>. x <= z) .&. - (forall x y. f[vt "x"] <= y .<=>. x <= g[vt "y"]) - .=>. (forall x y. x <= y .=>. f[vt "x"] <= f[vt "y"]) .&. - (forall x y. x <= y .=>. g[vt "x"] <= g[vt "y"])>>;; -END_INTERACTIVE;; - --- ------------------------------------------------------------------------- --- Do all the equality-free Pelletier problems, and more, as examples. --- ------------------------------------------------------------------------- - -{- ********** - -let p1 = time splittab - <

. q .<=>. ~q .=>. ~p>>;; - -let p2 = time splittab - <<~ ~p .<=>. p>>;; - -let p3 = time splittab - <<~(p .=>. q) .=>. q .=>. p>>;; - -let p4 = time splittab - <<~p .=>. q .<=>. ~q .=>. p>>;; - -let p5 = time splittab - <<(p .|. q .=>. p .|. r) .=>. p .|. (q .=>. r)>>;; - -let p6 = time splittab - <

>;; - -let p7 = time splittab - <

>;; - -let p8 = time splittab - <<((p .=>. q) .=>. p) .=>. p>>;; - -let p9 = time splittab - <<(p .|. q) .&. (~p .|. q) .&. (p .|. ~q) .=>. ~(~q .|. ~q)>>;; - -let p10 = time splittab - <<(q .=>. r) .&. (r .=>. p .&. q) .&. (p .=>. q .&. r) .=>. (p .<=>. q)>>;; - -let p11 = time splittab - <

. p>>;; - -let p12 = time splittab - <<((p .<=>. q) .<=>. r) .<=>. (p .<=>. (q .<=>. r))>>;; - -let p13 = time splittab - <

. (p .|. q) .&. (p .|. r)>>;; - -let p14 = time splittab - <<(p .<=>. q) .<=>. (q .|. ~p) .&. (~q .|. p)>>;; - -let p15 = time splittab - <

. q .<=>. ~p .|. q>>;; - -let p16 = time splittab - <<(p .=>. q) .|. (q .=>. p)>>;; - -let p17 = time splittab - <

. r) .=>. s .<=>. (~p .|. q .|. s) .&. (~p .|. ~r .|. s)>>;; - --- ------------------------------------------------------------------------- --- Pelletier problems: monadic predicate logic. --- ------------------------------------------------------------------------- - -let p18 = time splittab - <. P[vt "x"]>>;; - -let p19 = time splittab - <. Q[vt "z"]) .=>. P[vt "x"] .=>. Q[vt "x"]>>;; - -let p20 = time splittab - <<(forall x y. exists z. forall w. P[vt "x"] .&. Q[vt "y"] .=>. R[vt "z"] .&. U[vt "w"]) - .=>. (exists x y. P[vt "x"] .&. Q[vt "y"]) .=>. (exists z. R[vt "z"])>>;; - -let p21 = time splittab - <<(exists x. P .=>. Q[vt "x"]) .&. (exists x. Q[vt "x"] .=>. P) - .=>. (exists x. P .<=>. Q[vt "x"])>>;; - -let p22 = time splittab - <<(forall x. P .<=>. Q[vt "x"]) .=>. (P .<=>. (forall x. Q[vt "x"]))>>;; - -let p23 = time splittab - <<(forall x. P .|. Q[vt "x"]) .<=>. P .|. (forall x. Q[vt "x"])>>;; - -let p24 = time splittab - <<~(exists x. U[vt "x"] .&. Q[vt "x"]) .&. - (forall x. P[vt "x"] .=>. Q[vt "x"] .|. R[vt "x"]) .&. - ~(exists x. P[vt "x"] .=>. (exists x. Q[vt "x"])) .&. - (forall x. Q[vt "x"] .&. R[vt "x"] .=>. U[vt "x"]) .=>. - (exists x. P[vt "x"] .&. R[vt "x"])>>;; - -let p25 = time splittab - <<(exists x. P[vt "x"]) .&. - (forall x. U[vt "x"] .=>. ~G[vt "x"] .&. R[vt "x"]) .&. - (forall x. P[vt "x"] .=>. G[vt "x"] .&. U[vt "x"]) .&. - ((forall x. P[vt "x"] .=>. Q[vt "x"]) .|. (exists x. Q[vt "x"] .&. P[vt "x"])) - .=>. (exists x. Q[vt "x"] .&. P[vt "x"])>>;; - -let p26 = time splittab - <<((exists x. P[vt "x"]) .<=>. (exists x. Q[vt "x"])) .&. - (forall x y. P[vt "x"] .&. Q[vt "y"] .=>. (R[vt "x"] .<=>. U[vt "y"])) - .=>. ((forall x. P[vt "x"] .=>. R[vt "x"]) .<=>. (forall x. Q[vt "x"] .=>. U[vt "x"]))>>;; - -let p27 = time splittab - <<(exists x. P[vt "x"] .&. ~Q[vt "x"]) .&. - (forall x. P[vt "x"] .=>. R[vt "x"]) .&. - (forall x. U[vt "x"] .&. V[vt "x"] .=>. P[vt "x"]) .&. - (exists x. R[vt "x"] .&. ~Q[vt "x"]) - .=>. (forall x. U[vt "x"] .=>. ~R[vt "x"]) - .=>. (forall x. U[vt "x"] .=>. ~V[vt "x"])>>;; - -let p28 = time splittab - <<(forall x. P[vt "x"] .=>. (forall x. Q[vt "x"])) .&. - ((forall x. Q[vt "x"] .|. R[vt "x"]) .=>. (exists x. Q[vt "x"] .&. R[vt "x"])) .&. - ((exists x. R[vt "x"]) .=>. (forall x. L[vt "x"] .=>. M[vt "x"])) .=>. - (forall x. P[vt "x"] .&. L[vt "x"] .=>. M[vt "x"])>>;; - -let p29 = time splittab - <<(exists x. P[vt "x"]) .&. (exists x. G[vt "x"]) .=>. - ((forall x. P[vt "x"] .=>. H[vt "x"]) .&. (forall x. G[vt "x"] .=>. J[vt "x"]) .<=>. - (forall x y. P[vt "x"] .&. G[vt "y"] .=>. H[vt "x"] .&. J[vt "y"]))>>;; - -let p30 = time splittab - <<(forall x. P[vt "x"] .|. G[vt "x"] .=>. ~H[vt "x"]) .&. - (forall x. (G[vt "x"] .=>. ~U[vt "x"]) .=>. P[vt "x"] .&. H[vt "x"]) - .=>. (forall x. U[vt "x"])>>;; - -let p31 = time splittab - <<~(exists x. P[vt "x"] .&. (G[vt "x"] .|. H[vt "x"])) .&. - (exists x. Q[vt "x"] .&. P[vt "x"]) .&. - (forall x. ~H[vt "x"] .=>. J[vt "x"]) - .=>. (exists x. Q[vt "x"] .&. J[vt "x"])>>;; - -let p32 = time splittab - <<(forall x. P[vt "x"] .&. (G[vt "x"] .|. H[vt "x"]) .=>. Q[vt "x"]) .&. - (forall x. Q[vt "x"] .&. H[vt "x"] .=>. J[vt "x"]) .&. - (forall x. R[vt "x"] .=>. H[vt "x"]) - .=>. (forall x. P[vt "x"] .&. R[vt "x"] .=>. J[vt "x"])>>;; - -let p33 = time splittab - <<(forall x. P[vt "a"] .&. (P[vt "x"] .=>. P[vt "b"]) .=>. P[vt "c"]) .<=>. - (forall x. P[vt "a"] .=>. P[vt "x"] .|. P[vt "c"]) .&. (P[vt "a"] .=>. P[vt "b"] .=>. P[vt "c"])>>;; - -let p34 = time splittab - <<((exists x. forall y. P[vt "x"] .<=>. P[vt "y"]) .<=>. - ((exists x. Q[vt "x"]) .<=>. (forall y. Q[vt "y"]))) .<=>. - ((exists x. forall y. Q[vt "x"] .<=>. Q[vt "y"]) .<=>. - ((exists x. P[vt "x"]) .<=>. (forall y. P[vt "y"])))>>;; - -let p35 = time splittab - <. (forall x y. P(x,y))>>;; - --- ------------------------------------------------------------------------- --- Full predicate logic (without identity and functions). --- ------------------------------------------------------------------------- - -let p36 = time splittab - <<(forall x. exists y. P(x,y)) .&. - (forall x. exists y. G(x,y)) .&. - (forall x y. P(x,y) .|. G(x,y) - .=>. (forall z. P(y,z) .|. G(y,z) .=>. H(x,z))) - .=>. (forall x. exists y. H(x,y))>>;; - -let p37 = time splittab - <<(forall z. - exists w. forall x. exists y. (P(x,z) .=>. P(y,w)) .&. P(y,z) .&. - (P(y,w) .=>. (exists u. Q(u,w)))) .&. - (forall x z. ~P(x,z) .=>. (exists y. Q(y,z))) .&. - ((exists x y. Q(x,y)) .=>. (forall x. R(x,x))) .=>. - (forall x. exists y. R(x,y))>>;; - -let p38 = time splittab - <<(forall x. - P[vt "a"] .&. (P[vt "x"] .=>. (exists y. P[vt "y"] .&. R(x,y))) .=>. - (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))) .<=>. - (forall x. - (~P[vt "a"] .|. P[vt "x"] .|. (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))) .&. - (~P[vt "a"] .|. ~(exists y. P[vt "y"] .&. R(x,y)) .|. - (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))))>>;; - -let p39 = time splittab - <<~(exists x. forall y. P(y,x) .<=>. ~P(y,y))>>;; - -let p40 = time splittab - <<(exists y. forall x. P(x,y) .<=>. P(x,x)) - .=>. ~(forall x. exists y. forall z. P(z,y) .<=>. ~P(z,x))>>;; - -let p41 = time splittab - <<(forall z. exists y. forall x. P(x,y) .<=>. P(x,z) .&. ~P(x,x)) - .=>. ~(exists z. forall x. P(x,z))>>;; - -let p42 = time splittab - <<~(exists y. forall x. P(x,y) .<=>. ~(exists z. P(x,z) .&. P(z,x)))>>;; - -let p43 = time splittab - <<(forall x y. Q(x,y) .<=>. forall z. P(z,x) .<=>. P(z,y)) - .=>. forall x y. Q(x,y) .<=>. Q(y,x)>>;; - -let p44 = time splittab - <<(forall x. P[vt "x"] .=>. (exists y. G[vt "y"] .&. H(x,y)) .&. - (exists y. G[vt "y"] .&. ~H(x,y))) .&. - (exists x. J[vt "x"] .&. (forall y. G[vt "y"] .=>. H(x,y))) .=>. - (exists x. J[vt "x"] .&. ~P[vt "x"])>>;; - -let p45 = time splittab - <<(forall x. - P[vt "x"] .&. (forall y. G[vt "y"] .&. H(x,y) .=>. J(x,y)) .=>. - (forall y. G[vt "y"] .&. H(x,y) .=>. R[vt "y"])) .&. - ~(exists y. L[vt "y"] .&. R[vt "y"]) .&. - (exists x. P[vt "x"] .&. (forall y. H(x,y) .=>. - L[vt "y"]) .&. (forall y. G[vt "y"] .&. H(x,y) .=>. J(x,y))) .=>. - (exists x. P[vt "x"] .&. ~(exists y. G[vt "y"] .&. H(x,y)))>>;; - -let p46 = time splittab - <<(forall x. P[vt "x"] .&. (forall y. P[vt "y"] .&. H(y,x) .=>. G[vt "y"]) .=>. G[vt "x"]) .&. - ((exists x. P[vt "x"] .&. ~G[vt "x"]) .=>. - (exists x. P[vt "x"] .&. ~G[vt "x"] .&. - (forall y. P[vt "y"] .&. ~G[vt "y"] .=>. J(x,y)))) .&. - (forall x y. P[vt "x"] .&. P[vt "y"] .&. H(x,y) .=>. ~J(y,x)) .=>. - (forall x. P[vt "x"] .=>. G[vt "x"])>>;; - --- ------------------------------------------------------------------------- --- Well-known "Agatha" example; cf. Manthey and Bry, CADE-9. --- ------------------------------------------------------------------------- - -let p55 = time splittab - <. hates(x,y) .&. ~richer(x,y)) .&. - (forall x. hates(agatha,x) .=>. ~hates(charles,x)) .&. - (hates(agatha,agatha) .&. hates(agatha,charles)) .&. - (forall x. lives[vt "x"] .&. ~richer(x,agatha) .=>. hates(butler,x)) .&. - (forall x. hates(agatha,x) .=>. hates(butler,x)) .&. - (forall x. ~hates(x,agatha) .|. ~hates(x,butler) .|. ~hates(x,charles)) - .=>. killed(agatha,agatha) .&. - ~killed(butler,agatha) .&. - ~killed(charles,agatha)>>;; - -let p57 = time splittab - <. P(x,z)) - .=>. P(f(a,b),f(a,c))>>;; - --- ------------------------------------------------------------------------- --- See info-hol, circa 1500. --- ------------------------------------------------------------------------- - -let p58 = time splittab - <. ((P[vt "v"] .|. R[vt "w"]) .&. (R[vt "z"] .=>. Q[vt "v"])))>>;; - -let p59 = time splittab - <<(forall x. P[vt "x"] .<=>. ~P(f[vt "x"])) .=>. (exists x. P[vt "x"] .&. ~P(f[vt "x"]))>>;; - -let p60 = time splittab - <. - exists y. (forall z. P(z,y) .=>. P(z,f[vt "x"])) .&. P(x,y)>>;; - --- ------------------------------------------------------------------------- --- From Gilmore's classic paper. --- ------------------------------------------------------------------------- - -{- **** This is still too hard for us! Amazing... - -let gilmore_1 = time splittab - <. G[vt "y"]) .<=>. F[vt "x"]) .&. - ((F[vt "y"] .=>. H[vt "y"]) .<=>. G[vt "x"]) .&. - (((F[vt "y"] .=>. G[vt "y"]) .=>. H[vt "y"]) .<=>. H[vt "x"]) - .=>. F[vt "z"] .&. G[vt "z"] .&. H[vt "z"]>>;; - - ***** -} - -{- ** This is not valid, according to Gilmore - -let gilmore_2 = time splittab - <. F(z,y)) .&. (F(z,y) .<=>. F(z,z)) .&. (F(x,y) .<=>. F(y,x)) - .=>. (F(x,y) .<=>. F(x,z))>>;; - - ** -} - -let gilmore_3 = time splittab - <. (G[vt "y"] .=>. H[vt "x"])) .=>. F(x,x)) .&. - ((F(z,x) .=>. G[vt "x"]) .=>. H[vt "z"]) .&. - F(x,y) - .=>. F(z,z)>>;; - -let gilmore_4 = time splittab - <. F(y,z) .&. F(z,z)) .&. - (F(x,y) .&. G(x,y) .=>. G(x,z) .&. G(z,z))>>;; - -let gilmore_5 = time splittab - <<(forall x. exists y. F(x,y) .|. F(y,x)) .&. - (forall x y. F(y,x) .=>. F(y,y)) - .=>. exists z. F(z,z)>>;; - -let gilmore_6 = time splittab - <. G(v,u) .&. G(u,x)) - .=>. (exists u. forall v. F(u,y) .=>. G(v,u) .&. G(u,y)) .|. - (forall u v. exists w. G(v,u) .|. H(w,y,u) .=>. G(u,w))>>;; - -let gilmore_7 = time splittab - <<(forall x. K[vt "x"] .=>. exists y. L[vt "y"] .&. (F(x,y) .=>. G(x,y))) .&. - (exists z. K[vt "z"] .&. forall u. L[vt "u"] .=>. F(z,u)) - .=>. exists v w. K[vt "v"] .&. L[vt "w"] .&. G(v,w)>>;; - -let gilmore_8 = time splittab - <. (G[vt "y"] .=>. (forall u. exists v. H(u,v,x)))) .=>. F(x,x)) .&. - ((F(z,x) .=>. G[vt "x"]) .=>. (forall u. exists v. H(u,v,z))) .&. - F(x,y) - .=>. F(z,z)>>;; - -let gilmore_9 = time splittab - <. (forall u. exists v. F(x,u,v) .&. G(z,u) .&. ~H(x,z)) - .=>. (forall u. exists v. F(x,u,v) .&. G(y,u) .&. ~H(x,y))) .&. - ((forall u. exists v. F(x,u,v) .&. G(y,u) .&. ~H(x,y)) - .=>. ~(forall u. exists v. F(x,u,v) .&. G(z,u) .&. ~H(x,z)) - .=>. (forall u. exists v. F(y,u,v) .&. G(y,u) .&. ~H(y,x)) .&. - (forall u. exists v. F(z,u,v) .&. G(y,u) .&. ~H(z,y)))>>;; - --- ------------------------------------------------------------------------- --- Example from Davis-Putnam papers where Gilmore procedure is poor. --- ------------------------------------------------------------------------- - -let davis_putnam_example = time splittab - <. (F(y,z) .&. F(z,z))) .&. - ((F(x,y) .&. G(x,y)) .=>. (G(x,z) .&. G(z,z)))>>;; - -************ -} - --} diff --git a/Data/Logic/Harrison/Unif.hs b/Data/Logic/Harrison/Unif.hs deleted file mode 100644 --- a/Data/Logic/Harrison/Unif.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# OPTIONS -Wall #-} -module Data.Logic.Harrison.Unif - ( unify - , solve - , fullUnify - , unifyAndApply - ) where - -import Data.Logic.Classes.Term (Term(..), tsubst) -import Data.Logic.Failing (Failing(..), failing) -import qualified Data.Map as Map -{- -(* ========================================================================= *) -(* Unification for first order terms. *) -(* *) -(* Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) *) -(* ========================================================================= *) - -let rec istriv env x t = - match t with - Var y -> y = x or defined env y & istriv env x (apply env y) - | Fn(f,args) -> exists (istriv env x) args & failwith "cyclic";; --} -isTrivial :: Term term v f => Map.Map v term -> v -> term -> Failing Bool -isTrivial env x t = - foldTerm v f t - where - v y = - if x == y - then Success True - else maybe (Success False) (isTrivial env x) (Map.lookup y env) - f _ args = - if any (failing (const False) id . isTrivial env x) args - then Failure ["cyclic"] - else Success False - -{- - foldT (\ y -> y == x || (defined env y && istriv env x (apply env y))) - (\ _ args -> if any (istriv env x) args then error "cyclic" else False) - t --} -{- - -(* ------------------------------------------------------------------------- *) -(* Main unification procedure *) -(* ------------------------------------------------------------------------- *) - -let rec unify env eqs = - match eqs with - [] -> env - | (Fn(f,fargs),Fn(g,gargs))::oth -> - if f = g & length fargs = length gargs - then unify env (zip fargs gargs @ oth) - else failwith "impossible unification" - | (Var x,t)::oth | (t,Var x)::oth -> - if defined env x then unify env ((apply env x,t)::oth) - else unify (if istriv env x t then env else (x|->t) env) oth;; --} -unify :: Term term v f => Map.Map v term -> [(term,term)] -> Failing (Map.Map v term) -unify env [] = Success env -unify env ((a,b):oth) = - foldTerm (vr b) (\ f fargs -> foldTerm (vr a) (fn f fargs) b) a - where - vr t x = - maybe (isTrivial env x t >>= \ trivial -> unify (if trivial then env else Map.insert x t env) oth) - (\ y -> unify env ((y, t) : oth)) - (Map.lookup x env) - fn f fargs g gargs = - if f == g && length fargs == length gargs - then unify env (zip fargs gargs ++ oth) - else Failure ["impossible unification"] - -{- -(* ------------------------------------------------------------------------- *) -(* Solve to obtain a single instantiation. *) -(* ------------------------------------------------------------------------- *) - -let rec solve env = - let env' = mapf (tsubst env) env in - if env' = env then env else solve env';; --} -solve :: Term term v f => Map.Map v term -> Map.Map v term -solve env = - if env' == env then env else solve env' - where env' = Map.map (tsubst env) env -{- - -(* ------------------------------------------------------------------------- *) -(* Unification reaching a final solved form (often this isn't needed). *) -(* ------------------------------------------------------------------------- *) - -let fullunify eqs = solve (unify undefined eqs);; --} -fullUnify :: Term term v f => [(term,term)] -> Failing (Map.Map v term) -fullUnify eqs = failing Failure (Success . solve) (unify Map.empty eqs) -{- - -(* ------------------------------------------------------------------------- *) -(* Examples. *) -(* ------------------------------------------------------------------------- *) - -let unify_and_apply eqs = - let i = fullunify eqs in - let apply (t1,t2) = tsubst i t1,tsubst i t2 in - map apply eqs;; --} -unifyAndApply :: Term term v f => [(term, term)] -> Failing [(term, term)] -unifyAndApply eqs = - case fullUnify eqs of - Failure x -> Failure x - Success i -> Success (map (\ (t1, t2) -> (tsubst i t1, tsubst i t2)) eqs) -{- - -START_INTERACTIVE;; -unify_and_apply [<<|f(x,g(y))|>>,<<|f(f(z),w)|>>];; - -unify_and_apply [<<|f(x,y)|>>,<<|f(y,x)|>>];; - -(**** unify_and_apply [<<|f(x,g(y))|>>,<<|f(y,x)|>>];; *****) - -unify_and_apply [<<|x_0|>>,<<|f(x_1,x_1)|>>; - <<|x_1|>>,<<|f(x_2,x_2)|>>; - <<|x_2|>>,<<|f(x_3,x_3)|>>];; -END_INTERACTIVE;; --} diff --git a/Data/Logic/Instances/Chiou.hs b/Data/Logic/Instances/Chiou.hs --- a/Data/Logic/Instances/Chiou.hs +++ b/Data/Logic/Instances/Chiou.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, - RankNTypes, TypeSynonymInstances, UndecidableInstances #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, + RankNTypes, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} {-# OPTIONS -Wall -Wwarn -fno-warn-orphans -fno-warn-missing-signatures #-} module Data.Logic.Instances.Chiou ( Sentence(..) @@ -14,20 +14,21 @@ ) where import Data.Generics (Data, Typeable) -import Data.Logic.Classes.Apply (Apply(..), Predicate, pApp) +import Data.Logic.ATP.Apply (HasApply(..), IsPredicate, pApp) +import Data.Logic.ATP.Equate ((.=.), HasEquate(..), overtermsEq, ontermsEq) +import Data.Logic.ATP.Formulas (asBool, IsAtom, IsFormula(..)) +import Data.Logic.ATP.Lit ((.~.), associativityLiteral, convertToLiteral, IsLiteral(..), JustLiteral, + onatomsLiteral, overatomsLiteral, precedenceLiteral, prettyLiteral, showLiteral) +import Data.Logic.ATP.Pretty (Associativity(..), HasFixity(..), Side(Top), text) +import Data.Logic.ATP.Prop (BinOp(..), IsPropositional(..)) +import Data.Logic.ATP.Quantified (associativityQuantified, IsQuantified(..), onatomsQuantified, overatomsQuantified, + precedenceQuantified, prettyQuantified, Quant(..), showQuantified) +import Data.Logic.ATP.Skolem (HasSkolem(..), prettySkolem) +import Data.Logic.ATP.Term (associativityTerm, IsFunction, IsTerm(..), IsVariable, precedenceTerm, prettyTerm, showTerm) import Data.Logic.Classes.Atom (Atom) -import Data.Logic.Classes.Combine (Combinable(..), BinOp(..), Combination(..)) -import Data.Logic.Classes.Constants (Constants(..), asBool, true, false) -import Data.Logic.Classes.Equals (AtomEq(..), (.=.)) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), Quant(..), quant', prettyFirstOrder, fixityFirstOrder, foldAtomsFirstOrder, mapAtomsFirstOrder) -import Data.Logic.Classes.Formula (Formula(..)) -import Data.Logic.Classes.Negate (Negatable(..), (.~.)) -import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..)) -import Data.Logic.Classes.Term (Term(..), Function) -import Data.Logic.Classes.Variable (Variable) -import Data.Logic.Classes.Propositional (PropositionalFormula(..)) -import Data.Logic.Classes.Skolem (Skolem(..)) +import Data.Set as Set (notMember) import Data.String (IsString(..)) +import Text.PrettyPrint.HughesPJClass (Pretty(pPrint, pPrintPrec)) data Sentence v p f = Connective (Sentence v p f) Connective (Sentence v p f) @@ -35,6 +36,7 @@ | Not (Sentence v p f) | Predicate p [CTerm v f] | Equal (CTerm v f) (CTerm v f) + | TT | FF deriving (Eq, Ord, Data, Typeable) data CTerm v f @@ -42,6 +44,19 @@ | Variable v deriving (Eq, Ord, Data, Typeable) +instance IsString v => IsString (CTerm v f) where + fromString = Variable . fromString + +instance (IsVariable v, IsFunction f) => Show (CTerm v f) where + show = showTerm + +instance HasFixity (CTerm v f) where + precedence _ = 0 + associativity _ = InfixN + +instance (IsVariable v, Pretty v, IsFunction f, Pretty f) => Pretty (CTerm v f) where + pPrintPrec = prettyTerm + data Connective = Imply | Equiv @@ -54,138 +69,159 @@ | ExistsCh deriving (Eq, Ord, Show, Data, Typeable) -instance Negatable (Sentence v p f) where - negatePrivate = Not - foldNegation normal inverted (Not x) = foldNegation inverted normal x - foldNegation normal _ x = normal x - -instance (Constants p, Eq (Sentence v p f)) => Constants (Sentence v p f) where +{- +instance (Eq (Sentence v p f)) => HasBoolean (Sentence v p f) where fromBool x = Predicate (fromBool x) [] asBool x | fromBool True == x = Just True | fromBool False == x = Just False | True = Nothing - -instance ({- Constants (Sentence v p f), -} Ord v, Ord p, Ord f) => Combinable (Sentence v p f) where - x .<=>. y = Connective x Equiv y - x .=>. y = Connective x Imply y - x .|. y = Connective x Or y - x .&. y = Connective x And y +-} -instance (Predicate p, Function f v) => Formula (Sentence v p f) (Sentence v p f) where +instance (IsLiteral (Sentence v p f), + IsFunction f, IsVariable v, Ord p) => IsFormula (Sentence v p f) where + type AtomOf (Sentence v p f) = Sentence v p f atomic (Connective _ _ _) = error "Logic.Instances.Chiou.atomic: unexpected" atomic (Quantifier _ _ _) = error "Logic.Instances.Chiou.atomic: unexpected" atomic (Not _) = error "Logic.Instances.Chiou.atomic: unexpected" + atomic TT = error "Logic.Instances.Chiou.atomic: unexpected" + atomic FF = error "Logic.Instances.Chiou.atomic: unexpected" atomic x@(Predicate _ _) = x atomic x@(Equal _ _) = x - foldAtoms = foldAtomsFirstOrder - mapAtoms = mapAtomsFirstOrder + overatoms = overatomsQuantified + onatoms = onatomsQuantified + asBool TT = Just True + asBool FF = Just False + asBool _ = Nothing + true = TT + false = FF -instance (Formula (Sentence v p f) (Sentence v p f), Variable v, Predicate p, Function f v, Combinable (Sentence v p f)) => - PropositionalFormula (Sentence v p f) (Sentence v p f) where - foldPropositional co tf at formula = +instance (IsPropositional (Sentence v p f), + IsVariable v, IsFunction f) => IsPropositional (Sentence v p f) where + foldPropositional' ho co ne tf at formula = case formula of - Not x -> co ((:~:) x) - Quantifier _ _ _ -> error "Logic.Instance.Chiou.foldF0: unexpected" - Connective f1 Imply f2 -> co (BinOp f1 (:=>:) f2) - Connective f1 Equiv f2 -> co (BinOp f1 (:<=>:) f2) - Connective f1 And f2 -> co (BinOp f1 (:&:) f2) - Connective f1 Or f2 -> co (BinOp f1 (:|:) f2) - Predicate p ts -> maybe (at (Predicate p ts)) tf (asBool p) + Not x -> ne x + TT -> tf True + FF -> tf False + Connective f1 Imply f2 -> co f1 (:=>:) f2 + Connective f1 Equiv f2 -> co f1 (:<=>:) f2 + Connective f1 And f2 -> co f1 (:&:) f2 + Connective f1 Or f2 -> co f1 (:|:) f2 + Predicate p ts -> at (Predicate p ts) Equal t1 t2 -> at (Equal t1 t2) + _ -> ho formula + foldCombination other dj cj imp iff fm = + case fm of + (Connective l Equiv r) -> l `iff` r + (Connective l Imply r) -> l `imp` r + (Connective l Or r) -> l `dj` r + (Connective l And r) -> l `cj` r + _ -> other fm + x .<=>. y = Connective x Equiv y + x .=>. y = Connective x Imply y + x .|. y = Connective x Or y + x .&. y = Connective x And y +instance (IsVariable v, IsPredicate p, IsFunction f) => IsAtom (Sentence v p f) + +instance (IsVariable v, IsPredicate p, IsFunction f) => Show (Sentence v p f) where + showsPrec = showQuantified Top + +instance (IsVariable v, IsPredicate p, IsFunction f) => IsLiteral (Sentence v p f) where + foldLiteral' _ ne _ _ (Not x) = ne x + foldLiteral' _ _ tf _ TT = tf True + foldLiteral' _ _ tf _ FF = tf False + foldLiteral' _ _ _ at (Predicate p ts) = at (Predicate p ts) + foldLiteral' _ _ _ at (Equal t1 t2) = at (Equal t1 t2) + foldLiteral' ho _ _ _ fm = ho fm + naiveNegate = Not + foldNegation _ ne (Not x) = ne x + foldNegation other _ x = other x + data AtomicFunction v = AtomicFunction String -- This is redundant with the SkolemFunction and SkolemConstant -- constructors in the Chiou Term type. - | AtomicSkolemFunction v - deriving (Eq, Show) + | AtomicSkolemFunction v Int + deriving (Eq, Ord, Show) -instance IsString (AtomicFunction v) where +instance IsVariable v => IsString (AtomicFunction v) where fromString = AtomicFunction -instance Variable v => Skolem (AtomicFunction v) v where +instance IsVariable v => IsFunction (AtomicFunction v) where + +instance IsVariable v => Pretty (AtomicFunction v) where + pPrint = prettySkolem (\(AtomicFunction s) -> text s) + +instance IsVariable v => HasSkolem (AtomicFunction v) where + type SVarOf (AtomicFunction v) = v toSkolem = AtomicSkolemFunction - isSkolem (AtomicSkolemFunction _) = True - isSkolem _ = False + foldSkolem _ sk (AtomicSkolemFunction v n) = sk v n + foldSkolem f _ af = f af + variantSkolem f fns | Set.notMember f fns = f + variantSkolem (AtomicFunction s) fns = variantSkolem (AtomicFunction (s ++ "'")) fns + variantSkolem (AtomicSkolemFunction v n) fns = variantSkolem (AtomicSkolemFunction v (succ n)) fns -- The Atom type is not cleanly distinguished from the Sentence type, so we need an Atom instance for Sentence. -instance (Variable v, Predicate p, Function f v) => Apply (Sentence v p f) p (CTerm v f) where - foldApply ap tf (Predicate p ts) = maybe (ap p ts) tf (asBool p) - foldApply _ _ _ = error "Data.Logic.Instances.Chiou: Invalid atom" - apply' = Predicate +instance (IsVariable v, IsFunction f, IsPredicate p) => HasApply (Sentence v p f) where + type PredOf (Sentence v p f) = p + type TermOf (Sentence v p f) = CTerm v f + foldApply' _ ap (Predicate p ts) = ap p ts + foldApply' d _ p = d p + applyPredicate = Predicate + overterms = overtermsEq + onterms = ontermsEq -instance Predicate p => AtomEq (Sentence v p f) p (CTerm v f) where - foldAtomEq ap tf _ (Predicate p ts) = if p == true then tf True else if p == false then tf False else ap p ts - foldAtomEq _ _ eq (Equal t1 t2) = eq t1 t2 - foldAtomEq _ _ _ _ = error "Data.Logic.Instances.Chiou: Invalid atom" - equals = Equal - applyEq' = Predicate +instance (IsFunction f, IsVariable v, IsPredicate p) => HasEquate (Sentence v p f) where + foldEquate eq _ (Equal t1 t2) = eq t1 t2 + foldEquate _ ap (Predicate p ts) = ap p ts + foldEquate _ _ _ = error "IsAtomWithEquate Sentence" + equate = Equal + -- applyEq' = Predicate -instance (FirstOrderFormula (Sentence v p f) (Sentence v p f) v, Variable v, Predicate p, Function f v) => Pretty (Sentence v p f) where - pretty = prettyFirstOrder (\ _ a -> pretty a) pretty 0 +instance (IsQuantified (Sentence v p f), IsVariable v, IsFunction f) => Pretty (Sentence v p f) where + pPrintPrec = prettyQuantified Top -instance (Formula (Sentence v p f) (Sentence v p f), Predicate p, Function f v, Variable v) => HasFixity (Sentence v p f) where - fixity = fixityFirstOrder +instance (IsFormula (Sentence v p f), IsVariable v, IsPredicate p, IsFunction f) => HasFixity (Sentence v p f) where + precedence = precedenceQuantified + associativity = associativityQuantified -instance (Formula (Sentence v p f) (Sentence v p f), - Variable v, Predicate p, Function f v) => - FirstOrderFormula (Sentence v p f) (Sentence v p f) v where - for_all v x = Quantifier ForAll [v] x - exists v x = Quantifier ExistsCh [v] x - foldFirstOrder qu co tf at f = +instance (IsFormula (Sentence v p f), IsLiteral (Sentence v p f), IsVariable v, IsFunction f, Ord p + ) => IsQuantified (Sentence v p f) where + type (VarOf (Sentence v p f)) = v + quant (:!:) v x = Quantifier ForAll [v] x + quant (:?:) v x = Quantifier ExistsCh [v] x + foldQuantified qu co ne tf at f = case f of - Not x -> co ((:~:) x) + Not x -> ne x + TT -> tf True + FF -> tf False Quantifier op (v:vs) f' -> let op' = case op of - ForAll -> Forall - ExistsCh -> Exists in + ForAll -> (:!:) + ExistsCh -> (:?:) in -- Use Logic.quant' here instead of the constructor -- Quantifier so as not to create quantifications with -- empty variable lists. qu op' v (quant' op' vs f') - Quantifier _ [] f' -> foldFirstOrder qu co tf at f' - Connective f1 Imply f2 -> co (BinOp f1 (:=>:) f2) - Connective f1 Equiv f2 -> co (BinOp f1 (:<=>:) f2) - Connective f1 And f2 -> co (BinOp f1 (:&:) f2) - Connective f1 Or f2 -> co (BinOp f1 (:|:) f2) + Quantifier _ [] f' -> foldQuantified qu co ne tf at f' + Connective f1 Imply f2 -> co f1 (:=>:) f2 + Connective f1 Equiv f2 -> co f1 (:<=>:) f2 + Connective f1 And f2 -> co f1 (:&:) f2 + Connective f1 Or f2 -> co f1 (:|:) f2 Predicate _ _ -> at f Equal _ _ -> at f -{- - zipFirstOrder qu co tf at f1 f2 = - case (f1, f2) of - (Not f1', Not f2') -> co ((:~:) f1') ((:~:) f2') - (Quantifier op1 (v1:vs1) f1', Quantifier op2 (v2:vs2) f2') -> - if op1 == op2 - then let op' = case op1 of - ForAll -> Forall - ExistsCh -> Exists in - qu op' v1 (Quantifier op1 vs1 f1') Forall v2 (Quantifier op2 vs2 f2') - else Nothing - (Quantifier q1 [] f1', Quantifier q2 [] f2') -> - if q1 == q2 then zipFirstOrder qu co tf at f1' f2' else Nothing - (Connective l1 op1 r1, Connective l2 op2 r2) -> - case (op1, op2) of - (And, And) -> co (BinOp l1 (:&:) r1) (BinOp l2 (:&:) r2) - (Or, Or) -> co (BinOp l1 (:|:) r1) (BinOp l2 (:|:) r2) - (Imply, Imply) -> co (BinOp l1 (:=>:) r1) (BinOp l2 (:=>:) r2) - (Equiv, Equiv) -> co (BinOp l1 (:<=>:) r1) (BinOp l2 (:<=>:) r2) - _ -> Nothing - (Equal _ _, Equal _ _) -> at f1 f2 - (Predicate _ _, Predicate _ _) -> at f1 f2 - _ -> Nothing --} -instance (Variable v, Function f v) => Term (CTerm v f) v f where +quant' :: IsQuantified formula => Quant -> [VarOf formula] -> formula -> formula +quant' op vs f = foldr (quant op) f vs + +instance (IsVariable v, IsFunction f, Pretty (CTerm v f)) => IsTerm (CTerm v f) where + type TVarOf (CTerm v f) = v + type FunOf (CTerm v f) = f foldTerm v fn t = case t of Variable x -> v x Function f ts -> fn f ts - zipTerms v f t1 t2 = - case (t1, t2) of - (Variable v1, Variable v2) -> v v1 v2 - (Function f1 ts1, Function f2 ts2) -> f f1 ts1 f2 ts2 - _ -> Nothing vt = Variable fApp f ts = Function f ts @@ -197,110 +233,120 @@ = NFNot (NormalSentence v p f) | NFPredicate p [NormalTerm v f] | NFEqual (NormalTerm v f) (NormalTerm v f) + | NFTT + | NFFF deriving (Eq, Ord, Data, Typeable) -- We need a distinct type here because of the functional dependencies --- in class FirstOrderFormula. +-- in class IsQuantified. data NormalTerm v f = NormalFunction f [NormalTerm v f] | NormalVariable v deriving (Eq, Ord, Data, Typeable) -instance (Constants p, Eq (NormalSentence v p f)) => Constants (NormalSentence v p f) where - fromBool x = NFPredicate (fromBool x) [] - asBool x - | fromBool True == x = Just True - | fromBool False == x = Just False - | True = Nothing +instance (IsVariable v, IsPredicate p, IsFunction f) => Show (NormalSentence v p f) where + show = showLiteral -instance Negatable (NormalSentence v p f) where - negatePrivate = NFNot - foldNegation normal inverted (NFNot x) = foldNegation inverted normal x - foldNegation normal _ x = normal x +instance (IsVariable v, IsPredicate p, IsFunction f) => IsAtom (NormalSentence v p f) -{- -instance (Arity p, Constants p, Combinable (NormalSentence v p f)) => Pred p (NormalTerm v f) (NormalSentence v p f) where - pApp0 x = NFPredicate x [] - pApp1 x a = NFPredicate x [a] - pApp2 x a b = NFPredicate x [a,b] - pApp3 x a b c = NFPredicate x [a,b,c] - pApp4 x a b c d = NFPredicate x [a,b,c,d] - pApp5 x a b c d e = NFPredicate x [a,b,c,d,e] - pApp6 x a b c d e f = NFPredicate x [a,b,c,d,e,f] - pApp7 x a b c d e f g = NFPredicate x [a,b,c,d,e,f,g] - x .=. y = NFEqual x y - x .!=. y = NFNot (NFEqual x y) --} +instance (IsVariable v, IsPredicate p, IsFunction f) => JustLiteral (NormalSentence v p f) -instance (Formula (NormalSentence v p f) (NormalSentence v p f), - Variable v, Predicate p, Function f v, Combinable (NormalSentence v p f)) => Pretty (NormalSentence v p f) where - pretty = prettyFirstOrder (\ _ a -> pretty a) pretty 0 +instance (IsVariable v, IsPredicate p, IsFunction f) => IsLiteral (NormalSentence v p f) where + foldLiteral' _ho ne tf at fm = + case fm of + NFNot s -> ne s + NFTT -> tf True + NFFF -> tf False + NFPredicate _p _ts -> at fm + NFEqual _t1 _t2 -> at fm + naiveNegate = NFNot + foldNegation _ ne (NFNot x) = ne x + -- foldNegation' ne other (NFNot x) = foldNegation' other ne x + foldNegation other _ x = other x -instance (Predicate p, Function f v, Combinable (NormalSentence v p f)) => Formula (NormalSentence v p f) (NormalSentence v p f) where + +instance (IsLiteral (NormalSentence v p f), + IsVariable v, IsPredicate p, IsFunction f + ) => Pretty (NormalSentence v p f) where + pPrintPrec = prettyLiteral + +instance (Pretty (NormalTerm v f), + IsVariable v, IsPredicate p, IsFunction f + ) => IsFormula (NormalSentence v p f) where + type (AtomOf (NormalSentence v p f)) = NormalSentence v p f atomic x@(NFPredicate _ _) = x atomic x@(NFEqual _ _) = x atomic _ = error "Chiou: atomic" - foldAtoms = foldAtomsFirstOrder - mapAtoms = mapAtomsFirstOrder + overatoms = overatomsLiteral + onatoms = onatomsLiteral + true = NFTT + false = NFFF + asBool NFTT = Just True + asBool NFFF = Just False + asBool _ = Nothing -instance (Formula (NormalSentence v p f) (NormalSentence v p f), Combinable (NormalSentence v p f), Term (NormalTerm v f) v f, - Variable v, Predicate p, Function f v) => FirstOrderFormula (NormalSentence v p f) (NormalSentence v p f) v where - for_all _ _ = error "FirstOrderFormula NormalSentence" - exists _ _ = error "FirstOrderFormula NormalSentence" - foldFirstOrder _ co tf at f = - case f of - NFNot x -> co ((:~:) x) - NFEqual _ _ -> at f - NFPredicate p _ -> maybe (at f) tf (asBool p) -{- - zipFirstOrder _ co tf at f1 f2 = - case (f1, f2) of - (NFNot f1', NFNot f2') -> co ((:~:) f1') ((:~:) f2') - (NFEqual _ _, NFEqual _ _) -> at f1 f2 - (NFPredicate _ _, NFPredicate _ _) -> at f1 f2 - _ -> Nothing --} +instance (IsVariable v, IsPredicate p, IsFunction f) => HasFixity (NormalSentence v p f) where + precedence = precedenceLiteral + associativity = associativityLiteral -instance (Formula (NormalSentence v p f) (NormalSentence v p f), - Combinable (NormalSentence v p f), Predicate p, Function f v, Variable v) => HasFixity (NormalSentence v p f) where - fixity = fixityFirstOrder +instance IsVariable v => IsString (NormalTerm v f) where + fromString = NormalVariable . fromString -instance (Variable v, Function f v) => Term (NormalTerm v f) v f where +instance (IsFunction f, IsVariable v) => HasFixity (NormalTerm v f) where + precedence = precedenceTerm + associativity = associativityTerm + +instance (IsVariable v, IsFunction f, Pretty (NormalTerm v f)) => IsTerm (NormalTerm v f) where + type TVarOf (NormalTerm v f) = v + type FunOf (NormalTerm v f) = f vt = NormalVariable fApp = NormalFunction foldTerm v f t = case t of NormalVariable x -> v x NormalFunction x ts -> f x ts - zipTerms v fn t1 t2 = - case (t1, t2) of - (NormalVariable x1, NormalVariable x2) -> v x1 x2 - (NormalFunction f1 ts1, NormalFunction f2 ts2) -> fn f1 ts1 f2 ts2 - _ -> Nothing -toSentence :: (FirstOrderFormula (Sentence v p f) (Sentence v p f) v, Atom (Sentence v p f) (CTerm v f) v, Function f v, Variable v, Predicate p) => - NormalSentence v p f -> Sentence v p f +instance (IsVariable v, IsFunction f) => Pretty (NormalTerm v f) where + pPrintPrec = prettyTerm + +instance (IsVariable v, IsFunction f) => Show (NormalTerm v f) where + show = showTerm + +toSentence :: (IsQuantified (Sentence v p f), + Atom (Sentence v p f) (CTerm v f) v, + IsFunction f, IsVariable v, IsPredicate p + ) => NormalSentence v p f -> Sentence v p f toSentence (NFNot s) = (.~.) (toSentence s) +toSentence NFTT = true +toSentence NFFF = false toSentence (NFEqual t1 t2) = toTerm t1 .=. toTerm t2 toSentence (NFPredicate p ts) = pApp p (map toTerm ts) -toTerm :: (Variable v, Function f v) => NormalTerm v f -> CTerm v f +toTerm :: (IsVariable v, IsFunction f, Pretty (CTerm v f)) => NormalTerm v f -> CTerm v f toTerm (NormalFunction f ts) = fApp f (map toTerm ts) toTerm (NormalVariable v) = vt v -fromSentence :: forall v p f. (FirstOrderFormula (Sentence v p f) (Sentence v p f) v, Predicate p) => - Sentence v p f -> NormalSentence v p f -fromSentence = foldFirstOrder +fromSentence :: forall v p f fof atom. + (IsVariable v, IsPredicate p, IsFunction f, + fof ~ Sentence v p f, + atom ~ Sentence v p f, + IsQuantified fof + ) => Sentence v p f -> NormalSentence v p f +fromSentence = convertToLiteral (error "fromSentence failure") + (foldEquate (\ t1 t2 -> NFEqual (fromTerm t1) (fromTerm t2)) + (\ p ts -> NFPredicate p (map fromTerm ts))) +{- +fromSentence = convertQuantified (foldEquate (\ p ts -> applyPredicate p (map fromTerm ts)) + (\ t1 t2 -> equate (fromTerm t1) (fromTerm t2))) id +fromSentence = foldQuantified (\ _ _ _ -> error "fromSentence 1") (\ cm -> case cm of ((:~:) f) -> NFNot (fromSentence f) _ -> error "fromSentence 2") (\ x -> NFPredicate (fromBool x) []) - (foldAtomEq (\ p ts -> NFPredicate p (map fromTerm ts)) - (\ x -> NFPredicate (fromBool x) []) - (\ t1 t2 -> NFEqual (fromTerm t1) (fromTerm t2))) - + (\ a -> foldEquate (\ p ts -> NFPredicate p (map fromTerm ts)) (\ t1 t2 -> NFEqual (fromTerm t1) (fromTerm t2)) a) +-} fromTerm :: CTerm v f -> NormalTerm v f fromTerm (Function f ts) = NormalFunction f (map fromTerm ts) fromTerm (Variable v) = NormalVariable v diff --git a/Data/Logic/Instances/PropLogic.hs b/Data/Logic/Instances/PropLogic.hs --- a/Data/Logic/Instances/PropLogic.hs +++ b/Data/Logic/Instances/PropLogic.hs @@ -1,78 +1,79 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} {-# OPTIONS -fno-warn-orphans #-} module Data.Logic.Instances.PropLogic ( flatten - , plSat0 , plSat ) where -import Data.Logic.Classes.Atom (Atom) -import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..)) -import Data.Logic.Classes.Constants (Constants(fromBool, asBool)) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula) -import Data.Logic.Classes.Formula (Formula(..)) -import Data.Logic.Classes.Literal (Literal(..)) -import Data.Logic.Classes.Negate (Negatable(..)) -import Data.Logic.Classes.Pretty (HasFixity(fixity), Pretty(pretty), topFixity) -import Data.Logic.Classes.Propositional (PropositionalFormula(..), clauseNormalForm', prettyPropositional, fixityPropositional, foldAtomsPropositional, mapAtomsPropositional) -import Data.Logic.Classes.Term (Term) -import Data.Logic.Harrison.Skolem (SkolemT) -import Data.Logic.Normal.Clause (clauseNormalForm) -import qualified Data.Set.Extra as S -import PropLogic +import Data.Logic.ATP.Formulas (IsFormula(asBool), IsAtom, IsFormula(..)) +import Data.Logic.ATP.Lit (convertLiteral, IsLiteral(..), IsLiteral(..), LFormula) +import Data.Logic.ATP.Pretty (HasFixity(precedence, associativity), Pretty(pPrintPrec), Side(Top)) +import Data.Logic.ATP.Prop (BinOp(..), associativityPropositional, IsPropositional(..), JustPropositional, + precedencePropositional, prettyPropositional, simpcnf) +import Data.Set.Extra as Set (toList) +import PropLogic hiding (at) -instance Negatable (PropForm a) where - negatePrivate = N +instance IsAtom atom => JustPropositional (PropForm atom) + +instance IsAtom atom => IsLiteral (PropForm atom) where + naiveNegate = N foldNegation normal inverted (N x) = foldNegation inverted normal x foldNegation normal _ x = normal x + foldLiteral' ho ne tf at fm = + case fm of + N x -> ne x + T -> tf True + F -> tf False + A x -> at x + _ -> ho fm -instance {- Ord a => -} Combinable (PropForm a) where + +instance IsAtom atom => IsFormula (PropForm atom) where + type AtomOf (PropForm atom) = atom + atomic = A + overatoms = error "FIXME: overatoms PropForm" + onatoms = error "FIXME: onatoms PropForm" + true = T + false = F + asBool T = Just True + asBool F = Just False + asBool _ = Nothing + +instance IsAtom atom => IsPropositional (PropForm atom) where + foldCombination = error "FIXME: PropForm foldCombination" x .<=>. y = EJ [x, y] x .=>. y = SJ [x, y] x .|. y = DJ [x, y] x .&. y = CJ [x, y] - -instance (Pretty a, HasFixity a, Ord a) => Formula (PropForm a) a where - atomic = A - foldAtoms = foldAtomsPropositional - mapAtoms = mapAtomsPropositional - -instance (Combinable (PropForm a), Pretty a, HasFixity a, Ord a) => PropositionalFormula (PropForm a) a where - foldPropositional co tf at formula = + foldPropositional' ho co ne tf at formula = case formula of -- EJ [x,y,z,...] -> CJ [EJ [x,y], EJ[y,z], ...] EJ [] -> error "Empty equijunct" - EJ [x] -> foldPropositional co tf at x - EJ [x0, x1] -> co (BinOp x0 (:<=>:) x1) - EJ xs -> foldPropositional co tf at (CJ (map (\ (x0, x1) -> EJ [x0, x1]) (pairs xs))) + EJ [x] -> foldPropositional' ho co ne tf at x + EJ [x0, x1] -> co x0 (:<=>:) x1 + EJ xs -> foldPropositional' ho co ne tf at (CJ (map (\ (x0, x1) -> EJ [x0, x1]) (pairs xs))) SJ [] -> error "Empty subjunct" - SJ [x] -> foldPropositional co tf at x - SJ [x0, x1] -> co (BinOp x0 (:=>:) x1) - SJ xs -> foldPropositional co tf at (CJ (map (\ (x0, x1) -> SJ [x0, x1]) (pairs xs))) + SJ [x] -> foldPropositional' ho co ne tf at x + SJ [x0, x1] -> co x0 (:=>:) x1 + SJ xs -> foldPropositional' ho co ne tf at (CJ (map (\ (x0, x1) -> SJ [x0, x1]) (pairs xs))) DJ [] -> tf False - DJ [x] -> foldPropositional co tf at x - DJ (x0:xs) -> co (BinOp x0 (:|:) (DJ xs)) + DJ [x] -> foldPropositional' ho co ne tf at x + DJ (x0:xs) -> co x0 (:|:) (DJ xs) CJ [] -> tf True - CJ [x] -> foldPropositional co tf at x - CJ (x0:xs) -> co (BinOp x0 (:&:) (CJ xs)) - N x -> co ((:~:) x) - -- Not sure what to do about these - so far not an issue. + CJ [x] -> foldPropositional' ho co ne tf at x + CJ (x0:xs) -> co x0 (:&:) (CJ xs) + N x -> ne x T -> tf True F -> tf False A x -> at x -instance Constants (PropForm formula) where - fromBool True = T - fromBool False = F - asBool T = Just True - asBool F = Just False - asBool _ = Nothing - -instance (PropositionalFormula (PropForm atom) atom, Pretty atom, HasFixity atom) => Pretty (PropForm atom) where - pretty = prettyPropositional pretty topFixity +instance (IsPropositional (PropForm atom), IsAtom atom) => Pretty (PropForm atom) where + pPrintPrec = prettyPropositional Top -instance (PropositionalFormula (PropForm atom) atom, HasFixity atom) => HasFixity (PropForm atom) where - fixity = fixityPropositional +instance (IsPropositional (PropForm atom), IsAtom atom) => HasFixity (PropForm atom) where + precedence = precedencePropositional + associativity = associativityPropositional pairs :: [a] -> [(a, a)] pairs (x:y:zs) = (x,y) : pairs (y:zs) @@ -94,19 +95,16 @@ flatten (N x) = N (flatten x) flatten x = x -plSat0 :: (PropAlg a (PropForm formula), PropositionalFormula formula atom, Ord formula) => PropForm formula -> Bool -plSat0 f = satisfiable . (\ (x :: PropForm formula) -> x) . clauses0 $ f +{- +plSat0 :: (PropAlg a (PropForm atom), IsPropositional (PropForm atom) atom, Ord atom, Pretty atom, HasFixity atom) => PropForm atom -> Bool +plSat0 f = satisfiable . (\ (x :: PropForm atom) -> x) . clauses0 $ f -clauses0 :: (PropositionalFormula formula atom, Ord formula) => PropForm formula -> PropForm formula -clauses0 f = CJ . map DJ . map S.toList . S.toList $ clauseNormalForm' f +clauses0 :: (IsPropositional (PropForm atom) atom, Ord atom, Pretty atom, HasFixity atom) => PropForm atom -> PropForm atom +clauses0 = CJ . map (DJ . map unmarkLiteral . Set.toList) . Set.toList . simpcnf id +-} -plSat :: forall m formula atom term v f. (Monad m, FirstOrderFormula formula atom v, PropositionalFormula formula atom, Atom atom term v, Term term v f, Eq formula, Literal formula atom, Ord formula) => - formula -> SkolemT v term m Bool -plSat f = clauses f >>= (\ (x :: PropForm formula) -> return x) >>= return . satisfiable +plSat :: (IsPropositional (PropForm atom), IsAtom atom) => PropForm atom -> Bool +plSat = satisfiable . clauses -clauses :: forall m formula atom term v f. - (Monad m, FirstOrderFormula formula atom v, PropositionalFormula formula atom, Atom atom term v, Term term v f, Eq formula, Literal formula atom, Ord formula) => - formula -> SkolemT v term m (PropForm formula) -clauses f = - do (cnf :: S.Set (S.Set formula)) <- clauseNormalForm f - return . CJ . map DJ . map (map A) . map S.toList . S.toList $ cnf +clauses :: forall atom. IsPropositional (PropForm atom) => PropForm atom -> PropForm atom +clauses = CJ . map (DJ . map (convertLiteral id :: LFormula atom -> PropForm atom) . Set.toList) . Set.toList . simpcnf id diff --git a/Data/Logic/Instances/SatSolver.hs b/Data/Logic/Instances/SatSolver.hs --- a/Data/Logic/Instances/SatSolver.hs +++ b/Data/Logic/Instances/SatSolver.hs @@ -1,58 +1,67 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving, TypeFamilies, TypeSynonymInstances #-} {-# OPTIONS -fno-warn-orphans #-} module Data.Logic.Instances.SatSolver where import Control.Monad.State (get, put) import Control.Monad.Trans (lift) -import Data.Boolean.SatSolver (Literal(Pos, Neg), CNF, newSatSolver, assertTrue', solve) -import Data.Generics (Data, Typeable) -import qualified Data.Set.Extra as S -import Data.Logic.Classes.Atom (Atom) +import Data.Boolean (Literal(Pos, Neg), CNF) +import Data.Boolean.SatSolver (newSatSolver, assertTrue', solve) +import Data.Logic.ATP.Apply (HasApply(PredOf, TermOf)) +import Data.Logic.ATP.FOL (IsFirstOrder) +import Data.Logic.ATP.Formulas (IsAtom, IsFormula(..)) +import Data.Logic.ATP.Lit (IsLiteral(..), negated, (.~.)) +import Data.Logic.ATP.Pretty (Associativity(InfixN), HasFixity(..), Pretty) +import Data.Logic.ATP.Quantified (IsQuantified(VarOf)) +import Data.Logic.ATP.Skolem (simpcnf') +import Data.Logic.ATP.Term (IsTerm(FunOf, TVarOf)) import Data.Logic.Classes.ClauseNormalForm (ClauseNormalFormula(..)) -import Data.Logic.Classes.Equals (AtomEq) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..)) -import qualified Data.Logic.Classes.Literal as N -import Data.Logic.Classes.Negate (Negatable(..), negated, (.~.)) -import Data.Logic.Classes.Propositional (PropositionalFormula) -import Data.Logic.Classes.Term (Term) -import Data.Logic.Normal.Clause (clauseNormalForm) import Data.Logic.Normal.Implicative (LiteralMapT, NormalT) import qualified Data.Map as M +import qualified Data.Set.Extra as S -instance Ord Literal where - compare (Neg _) (Pos _) = LT - compare (Pos _) (Neg _) = GT - compare (Pos m) (Pos n) = compare m n - compare (Neg m) (Neg n) = compare m n +instance HasFixity Literal where + precedence _ = 0 + associativity _ = InfixN -instance Negatable Literal where - negatePrivate (Neg x) = Pos x - negatePrivate (Pos x) = Neg x - foldNegation _ inverted (Neg x) = inverted (Pos x) - foldNegation normal _ (Pos x) = normal (Pos x) +instance IsAtom Literal -deriving instance Data Literal -deriving instance Typeable Literal +instance IsFormula Literal where + type AtomOf Literal = Int + true = error "true :: IsLiteral" + false = error "false :: IsLiteral" + asBool _ = Nothing + overatoms f (Pos x) r = f x r + overatoms f (Neg x) r = f x r + onatoms f (Pos x) = Pos (f x) + onatoms f (Neg x) = Neg (f x) + atomic = error "atomic" +instance IsLiteral Literal where + naiveNegate (Pos x) = Neg x + naiveNegate (Neg x) = Pos x + foldNegation pos _ (Pos x) = pos (Pos x) + foldNegation _ neg (Neg x) = neg (Pos x) + foldLiteral' _ _ _ at (Pos x) = at x + foldLiteral' _ ne _ _ (Neg x) = ne (Pos x) + instance ClauseNormalFormula CNF Literal where clauses = S.fromList . map S.fromList makeCNF = map S.toList . S.toList satisfiable cnf = return . not . (null :: [a] -> Bool) $ assertTrue' cnf newSatSolver >>= solve -toCNF :: (Monad m, - FirstOrderFormula formula atom v, - PropositionalFormula formula atom, - Atom atom term v, - AtomEq atom p term, - Term term v f, - N.Literal formula atom, - Ord formula) => - formula -> NormalT formula v term m CNF -toCNF f = clauseNormalForm f >>= S.ssMapM (lift . toLiteral) >>= return . makeCNF +toCNF :: (atom ~ AtomOf formula, p ~ PredOf atom, term ~ TermOf atom, v ~ VarOf formula, v ~ TVarOf term, function ~ FunOf term, + Monad m, + IsFirstOrder formula, + -- IsAtomWithEquate atom p term, + IsLiteral formula, + Ord formula, Pretty formula) => + formula -> NormalT formula m CNF +toCNF f = S.ssMapM (lift . toLiteral) (simpcnf' f) >>= return . makeCNF -- |Convert a [[formula]] to CNF, which means building a map from -- formula to Literal. -toLiteral :: forall m lit. (Monad m, Negatable lit, Ord lit) => +toLiteral :: forall m lit. (Monad m, IsLiteral lit, Ord lit) => lit -> LiteralMapT lit m Literal toLiteral f = literalNumber >>= return . if negated f then Neg else Pos diff --git a/Data/Logic/Instances/Test.hs b/Data/Logic/Instances/Test.hs new file mode 100644 --- /dev/null +++ b/Data/Logic/Instances/Test.hs @@ -0,0 +1,38 @@ +-- | Formula instance used in the unit tests. +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, TypeFamilies #-} +module Data.Logic.Instances.Test + ( V(..) + , Predicate + , QFormula(..) + , Term(..) + , Function(..) + , Formula, SkAtom, SkTerm + , TFormula, TAtom, TTerm -- deprecated + ) where + +import Data.Char (isDigit) +import Data.Logic.ATP.Apply (Predicate) +import Data.Logic.ATP.Equate (FOL(..)) +import Data.Logic.ATP.Quantified (Quant(..), QFormula(..)) +import Data.Logic.ATP.Prop (BinOp(..)) +import Data.Logic.ATP.Skolem (Function(..), Formula, SkTerm, SkAtom) +import Data.Logic.ATP.Term (V(V), Term(..)) +import Data.SafeCopy (base, deriveSafeCopy) + +next :: String -> String +next s = + case break (not . isDigit) (reverse s) of + (_, "") -> "x" + ("", nondigits) -> nondigits ++ "2" + (digits, nondigits) -> nondigits ++ show (1 + read (reverse digits) :: Int) + +type TFormula = Formula +type TAtom = SkAtom +type TTerm = SkTerm + +$(deriveSafeCopy 1 'base ''BinOp) +$(deriveSafeCopy 1 'base ''Quant) +$(deriveSafeCopy 1 'base ''Predicate) +$(deriveSafeCopy 1 'base ''Term) +$(deriveSafeCopy 1 'base ''FOL) +$(deriveSafeCopy 1 'base ''QFormula) diff --git a/Data/Logic/KnowledgeBase.hs b/Data/Logic/KnowledgeBase.hs --- a/Data/Logic/KnowledgeBase.hs +++ b/Data/Logic/KnowledgeBase.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, PackageImports, - RankNTypes, TemplateHaskell, TypeSynonymInstances, UndecidableInstances #-} + RankNTypes, TemplateHaskell, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} {-# OPTIONS -Wall #-} {- KnowledgeBase.hs -} @@ -7,7 +7,7 @@ module Data.Logic.KnowledgeBase ( WithId(WithId, wiItem, wiIdent) -- Probably only used by some unit tests, and not really correctly - , ProverT + , ProverT, ProverT' , runProver' , runProverT' , getKB @@ -28,18 +28,20 @@ import "mtl" Control.Monad.State (StateT, evalStateT, MonadState(get, put)) import "mtl" Control.Monad.Trans (lift) import Data.Generics (Data, Typeable) +import Data.Logic.ATP.Apply (HasApply(TermOf, PredOf)) +import Data.Logic.ATP.Equate (HasEquate) +import Data.Logic.ATP.FOL (IsFirstOrder) +import Data.Logic.ATP.Formulas (IsFormula(AtomOf)) +import Data.Logic.ATP.Lit ((.~.), IsLiteral, LFormula) +import Data.Logic.ATP.Pretty (Pretty(pPrint), text, (<>)) +import Data.Logic.ATP.Quantified (IsQuantified(VarOf)) +import Data.Logic.ATP.Skolem (SkolemT, runSkolemT, HasSkolem(SVarOf)) +import Data.Logic.ATP.Term (IsFunction, IsTerm(FunOf, TVarOf)) import Data.Logic.Classes.Atom (Atom) -import Data.Logic.Classes.Equals (AtomEq) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula) -import Data.Logic.Classes.Literal (Literal) -import Data.Logic.Classes.Negate ((.~.)) -import Data.Logic.Classes.Propositional (PropositionalFormula) -import Data.Logic.Classes.Term (Term) -import Data.Logic.Harrison.Skolem (SkolemT, runSkolemT) -import Data.Logic.Normal.Implicative (ImplicativeForm, implicativeNormalForm) +import Data.Logic.Normal.Implicative (ImplicativeForm, implicativeNormalForm, prettyProof) import Data.Logic.Resolution (prove, SetOfSupport, getSetOfSupport) import Data.SafeCopy (deriveSafeCopy, base) -import qualified Data.Set.Extra as S +import Data.Set.Extra as Set (Set, empty, map, minView, null, partition, union) import Prelude hiding (negate) type SentenceCount = Int @@ -63,7 +65,7 @@ wiLookupItem i xs = lookup i (withIdPairs' xs) -} -type KnowledgeBase inf = S.Set (WithId inf) +type KnowledgeBase inf = Set (WithId inf) data ProverState inf = ProverState @@ -75,18 +77,18 @@ zeroKB limit = ProverState { recursionLimit = limit - , knowledgeBase = S.empty + , knowledgeBase = Set.empty , sentenceCount = 1 } -- |A monad for running the knowledge base. type ProverT inf = StateT (ProverState inf) -type ProverT' v term inf m a = ProverT inf (SkolemT v term m) a +type ProverT' v term lit m a = ProverT (ImplicativeForm lit) (SkolemT m (FunOf term)) a -runProverT' :: Monad m => Maybe Int -> ProverT' v term inf m a -> m a +runProverT' :: (Monad m, IsFunction (FunOf term), term ~ TermOf atom, atom ~ AtomOf lit) => Maybe Int -> ProverT' v term lit m a -> m a runProverT' limit = runSkolemT . runProverT limit runProverT :: Monad m => Maybe Int -> StateT (ProverState inf) m a -> m a runProverT limit action = evalStateT action (zeroKB limit) -runProver' :: Maybe Int -> ProverT' v term inf Identity a -> a +runProver' :: (IsFunction (FunOf term), term ~ TermOf atom, atom ~ AtomOf lit) => Maybe Int -> ProverT' v term lit Identity a -> a runProver' limit = runIdentity . runProverT' limit {- runProver :: StateT (ProverState inf) Identity a -> a @@ -102,58 +104,95 @@ -- ^ Both are satisfiable deriving (Data, Typeable, Eq, Ord, Show) +instance Pretty ProofResult where + pPrint = text . show + $(deriveSafeCopy 1 'base ''ProofResult) -data Proof lit = Proof {proofResult :: ProofResult, proof :: S.Set (ImplicativeForm lit)} deriving (Data, Typeable, Eq, Ord) +data Proof lit = Proof {proofResult :: ProofResult, proof :: Set (ImplicativeForm lit)} deriving (Data, Typeable, Eq, Ord) -instance (Ord lit, Show lit, Literal lit atom, FirstOrderFormula lit atom v) => Show (Proof lit) where +instance (Ord lit, Show lit, IsLiteral lit) => Show (Proof lit) where show p = "Proof {proofResult = " ++ show (proofResult p) ++ ", proof = " ++ show (proof p) ++ "}" +instance (Ord lit, Pretty lit, Show lit, IsLiteral lit) => Pretty (Proof lit) where + pPrint p = text "Proof {\n proofResult = " <> pPrint (proofResult p) <> text ",\n proof = " <> prettyProof (proof p) <> text "\n}" + -- |Remove a particular sentence from the knowledge base unloadKB :: (Monad m, Ord inf) => SentenceCount -> ProverT inf m (Maybe (KnowledgeBase inf)) unloadKB n = do st <- get - let (discard, keep) = S.partition ((== n) . wiIdent) (knowledgeBase st) + let (discard, keep) = Set.partition ((== n) . wiIdent) (knowledgeBase st) put (st {knowledgeBase = keep}) >> return (Just discard) -- |Return the contents of the knowledgebase. -getKB :: Monad m => ProverT inf m (S.Set (WithId inf)) +getKB :: Monad m => ProverT inf m (Set (WithId inf)) getKB = get >>= return . knowledgeBase -- |Return a flag indicating whether sentence was disproved, along -- with a disproof. -inconsistantKB :: forall m formula atom term v p f lit. - (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal lit atom, Atom atom term v, AtomEq atom p term, Term term v f, - Monad m, Ord formula, Data formula, Data lit, Eq lit, Ord lit, Ord term) => - formula -> ProverT' v term (ImplicativeForm lit) m (Bool, SetOfSupport lit v term) +inconsistantKB :: forall m fof lit atom term v function. + (IsFirstOrder fof, Ord fof, lit ~ LFormula atom, + Atom atom term v, + HasEquate atom, + IsTerm term, + HasSkolem function, + Monad m, Data lit, Pretty fof, Typeable function, + atom ~ AtomOf fof, term ~ TermOf atom, function ~ FunOf term, + v ~ TVarOf term, v ~ SVarOf function) => + fof -> ProverT' v term lit m (Bool, SetOfSupport lit v term) inconsistantKB s = get >>= \ st -> lift (implicativeNormalForm s) >>= return . getSetOfSupport >>= \ sos -> getKB >>= - return . prove (recursionLimit st) S.empty sos . S.map wiItem + return . prove (recursionLimit st) Set.empty sos . Set.map wiItem -- |Return a flag indicating whether sentence was proved, along with a -- proof. -theoremKB :: forall m formula atom term v p f lit. - (Monad m, FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal lit atom, Atom atom term v, AtomEq atom p term, Term term v f, - Ord formula, Ord term, Ord lit, Data formula, Data lit) => - formula -> ProverT' v term (ImplicativeForm lit) m (Bool, SetOfSupport lit v term) +theoremKB :: forall m fof lit atom term v function. + (Monad m, + IsFirstOrder fof, Ord fof, Pretty fof, lit ~ LFormula atom, + Atom atom term v, + HasEquate atom, + IsTerm term, + HasSkolem function, + Data lit, Typeable function, + atom ~ AtomOf fof, term ~ TermOf atom, + function ~ FunOf term, + v ~ VarOf fof, v ~ SVarOf function) => + fof -> ProverT' v term lit m (Bool, SetOfSupport lit v term) theoremKB s = inconsistantKB ((.~.) s) -- |Try to prove a sentence, return the result and the proof. -- askKB should be in KnowledgeBase module. However, since resolution -- is here functions are here, it is also placed in this module. -askKB :: (Monad m, FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal lit atom, Atom atom term v, AtomEq atom p term, Term term v f, - Ord formula, Ord term, Ord lit, Data formula, Data lit) => - formula -> ProverT' v term (ImplicativeForm lit) m Bool +askKB :: (Monad m, + IsFirstOrder fof, Ord fof, Pretty fof, lit ~ LFormula atom, + Atom atom term v, + HasEquate atom, + IsTerm term, + HasSkolem function, + Data lit, Typeable function, + atom ~ AtomOf fof, term ~ TermOf atom, p ~ PredOf atom, + function ~ FunOf term, + v ~ VarOf fof, v ~ SVarOf function) => + fof -> ProverT' v term lit m Bool askKB s = theoremKB s >>= return . fst -- |See whether the sentence is true, false or invalid. Return proofs -- for truth and falsity. -validKB :: (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal lit atom, Atom atom term v, AtomEq atom p term, Term term v f, - Monad m, Ord formula, Ord term, Ord lit, Data formula, Data lit) => - formula -> ProverT' v term (ImplicativeForm lit) m (ProofResult, SetOfSupport lit v term, SetOfSupport lit v term) +validKB :: (IsFirstOrder fof, Ord fof, Pretty fof, lit ~ LFormula atom, + Atom atom term v, + HasEquate atom, + IsTerm term, + HasSkolem function, + Monad m, Data lit, Typeable function, + atom ~ AtomOf fof, term ~ TermOf atom, p ~ PredOf atom, + function ~ FunOf term, + v ~ VarOf fof, v ~ SVarOf function) => + fof -> ProverT' v term lit m (ProofResult, + SetOfSupport lit v term, + SetOfSupport lit v term) validKB s = theoremKB s >>= \ (proved, proof1) -> inconsistantKB s >>= \ (disproved, proof2) -> @@ -162,23 +201,37 @@ -- |Validate a sentence and insert it into the knowledgebase. Returns -- the INF sentences derived from the new sentence, or Nothing if the -- new sentence is inconsistant with the current knowledgebase. -tellKB :: (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal lit atom, Atom atom term v, AtomEq atom p term, Term term v f, - Monad m, Ord formula, Data formula, Data lit, Eq lit, Ord lit, Ord term) => - formula -> ProverT' v term (ImplicativeForm lit) m (Proof lit) +tellKB :: (IsFirstOrder fof, Ord fof, Pretty fof, lit ~ LFormula atom, + Atom atom term v, + HasEquate atom, + IsTerm term, + HasSkolem function, + Monad m, Data lit, Typeable function, + atom ~ AtomOf fof, term ~ TermOf atom, p ~ PredOf atom, + function ~ FunOf term, + v ~ VarOf fof, v ~ SVarOf function) => + fof -> ProverT' v term lit m (Proof lit) tellKB s = do st <- get inf <- lift (implicativeNormalForm s) - let inf' = S.map (withId (sentenceCount st)) inf + let inf' = Set.map (withId (sentenceCount st)) inf (valid, _, _) <- validKB s case valid of Disproved -> return () - _ -> put st { knowledgeBase = S.union (knowledgeBase st) inf' + _ -> put st { knowledgeBase = Set.union (knowledgeBase st) inf' , sentenceCount = sentenceCount st + 1 } - return $ Proof {proofResult = valid, proof = S.map wiItem inf'} + return $ Proof {proofResult = valid, proof = Set.map wiItem inf'} -loadKB :: (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal lit atom, Atom atom term v, AtomEq atom p term, Term term v f, - Monad m, Ord formula, Ord term, Ord lit, Data formula, Data lit) => - [formula] -> ProverT' v term (ImplicativeForm lit) m [Proof lit] +loadKB :: (IsFirstOrder fof, Ord fof, Pretty fof, lit ~ LFormula atom, + Atom atom term v, + IsTerm term, + HasEquate atom, + HasSkolem function, + Monad m, Data lit, Typeable function, + atom ~ AtomOf fof, term ~ TermOf atom, + function ~ FunOf term, + v ~ VarOf fof, v ~ SVarOf function) => + [fof] -> StateT (ProverState (ImplicativeForm lit)) (SkolemT m (FunOf term)) [Proof lit] loadKB sentences = mapM tellKB sentences -- |Delete an entry from the KB. @@ -191,7 +244,7 @@ "Deleted" else "Failed to delete") - + deleteElement :: Int -> [a] -> [a] deleteElement i l | i <= 0 = l @@ -209,10 +262,10 @@ reportKB :: (Show inf) => ProverState inf -> String reportKB st@(ProverState {knowledgeBase = kb}) = - case S.minView kb of + case Set.minView kb of Nothing -> "Nothing in Knowledge Base\n" Just (WithId {wiItem = x, wiIdent = n}, kb') - | S.null kb' -> + | Set.null kb' -> show n ++ ") " ++ "\t" ++ show x ++ "\n" | True -> show n ++ ") " ++ "\t" ++ show x ++ "\n" ++ reportKB (st {knowledgeBase = kb'}) diff --git a/Data/Logic/Normal/Clause.hs b/Data/Logic/Normal/Clause.hs --- a/Data/Logic/Normal/Clause.hs +++ b/Data/Logic/Normal/Clause.hs @@ -25,23 +25,23 @@ -- ~wise(x(Y)) | wise(Y) } -- @ -- -{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} {-# OPTIONS -Wall #-} module Data.Logic.Normal.Clause - ( clauseNormalForm - , cnfTrace + ( {- clauseNormalForm + , cnfTrace -} ) where - -import Data.List (intersperse) +#if 0 +import Data.List as List (intersperse, map) import Data.Logic.Classes.Atom (Atom) -import Data.Logic.Classes.Equals (AtomEq, prettyAtomEq) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), prettyFirstOrder) -import Data.Logic.Classes.Literal (Literal(..), prettyLit) -import Data.Logic.Classes.Propositional (PropositionalFormula) -import Data.Logic.Classes.Term (Term) +import Data.Logic.Classes.Equals (HasEquality, prettyAtomEq) +import Data.Logic.Classes.FirstOrder (IsQuantified(..), prettyFirstOrder) +import Data.Logic.Classes.Literal (IsLiteral(..)) +import Data.Logic.Classes.Propositional (IsPropositional) +import Data.Logic.Classes.Term (IsTerm) import Data.Logic.Harrison.Normal (simpcnf') import Data.Logic.Harrison.Skolem (skolemize, SkolemT, pnf, nnf, simplify) -import qualified Data.Set.Extra as Set +import Data.Set.Extra as Set (fromSS, Set) import Text.PrettyPrint (Doc, hcat, vcat, text, nest, ($$), brackets, render) -- |Convert to Skolem Normal Form and then distribute the disjunctions over the conjunctions: @@ -54,23 +54,23 @@ -- clauseNormalForm :: forall formula atom term v f lit m. (Monad m, - FirstOrderFormula formula atom v, - PropositionalFormula formula atom, + IsQuantified formula atom v, + IsPropositional formula atom, Atom atom term v, - Term term v f, - Literal lit atom, + IsTerm term v f, + IsLiteral lit atom, Ord formula, Ord lit) => formula -> SkolemT v term m (Set.Set (Set.Set lit)) clauseNormalForm fm = skolemize id fm >>= return . (simpcnf' :: formula -> Set.Set (Set.Set lit)) cnfTrace :: forall m formula atom term v p f lit. (Monad m, - FirstOrderFormula formula atom v, - PropositionalFormula formula atom, + IsQuantified formula atom v, + IsPropositional formula atom, Atom atom term v, - AtomEq atom p term, - Term term v f, - Literal lit atom, + HasEquality atom p term, + IsTerm term v f, + IsLiteral lit atom, Ord formula, Ord lit) => (v -> Doc) -> (p -> Doc) @@ -86,8 +86,8 @@ text "Negation Normal Form:" $$ nest 2 (prettyFirstOrder (prettyAtomEq pv pp pf) pv 0 (nnf . simplify $ f)), text "Prenex Normal Form:" $$ nest 2 (prettyFirstOrder (prettyAtomEq pv pp pf) pv 0 (pnf f)), text "Skolem Normal Form:" $$ nest 2 (prettyFirstOrder (prettyAtomEq pv pp pf) pv 0 snf), - text "Clause Normal Form:" $$ vcat (map prettyClause (fromSS cnf))]), cnf) + text "Clause Normal Form:" $$ vcat (List.map prettyClause (fromSS cnf))]), cnf) where prettyClause (clause :: [lit]) = - nest 2 . brackets . hcat . intersperse (text ", ") . map (nest 2 . brackets . prettyLit (prettyAtomEq pv pp pf) pv 0) $ clause - fromSS = (map Set.toList) . Set.toList + nest 2 . brackets . hcat . intersperse (text ", ") . List.map (nest 2 . brackets . pPrint) $ clause +#endif diff --git a/Data/Logic/Normal/Implicative.hs b/Data/Logic/Normal/Implicative.hs --- a/Data/Logic/Normal/Implicative.hs +++ b/Data/Logic/Normal/Implicative.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, PackageImports, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, PackageImports, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} {-# OPTIONS -Wall #-} module Data.Logic.Normal.Implicative ( LiteralMapT @@ -14,33 +14,33 @@ import Control.Monad.Identity (Identity(runIdentity)) import Control.Monad.State (StateT(runStateT), MonadPlus, msum) +import Data.Bool (bool) import Data.Generics (Data, Typeable, listify) -import Data.List (intersperse) -import Data.Logic.Classes.Atom (Atom) -import Data.Logic.Classes.Constants (true, ifElse) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..)) -import Data.Logic.Classes.Propositional (PropositionalFormula) -import Data.Logic.Classes.Skolem (Skolem(isSkolem)) -import Data.Logic.Classes.Literal (Literal(..)) -import Data.Logic.Classes.Negate (Negatable(..)) -import Data.Logic.Classes.Term (Term) -import Data.Logic.Harrison.Skolem (SkolemT, runSkolemT) -import Data.Logic.Normal.Clause (clauseNormalForm) -import qualified Data.Set.Extra as Set -import qualified Data.Map as Map -import Text.PrettyPrint (Doc, cat, text, hsep) +import Data.List as List (map) +import Data.Logic.ATP.Apply (HasApply(TermOf)) +import Data.Logic.ATP.FOL (IsFirstOrder) +import Data.Logic.ATP.Formulas (IsFormula(AtomOf), true) +import Data.Logic.ATP.Lit (foldLiteral, IsLiteral, JustLiteral, LFormula) +import Data.Logic.ATP.Pretty (Pretty(pPrint)) +import Data.Logic.ATP.Prop (IsPropositional, PFormula, simpcnf) +import Data.Logic.ATP.Quantified (IsQuantified(VarOf)) +import Data.Logic.ATP.Skolem (HasSkolem(SVarOf, foldSkolem), runSkolem, runSkolemT, skolemize, SkolemT) +import Data.Logic.ATP.Term (IsFunction, IsTerm(FunOf)) +import Data.Map as Map (empty, Map) +import Data.Set.Extra as Set (empty, flatten, fold, fromList, insert, map, Set, singleton, toList) +import Text.PrettyPrint ((<>), Doc, brackets, comma, hsep, parens, punctuate, text, vcat) -- |Combination of Normal monad and LiteralMap monad -type NormalT formula v term m a = SkolemT v term (LiteralMapT formula m) a +type NormalT lit m a = SkolemT (LiteralMapT lit m) (FunOf (TermOf (AtomOf lit))) a -runNormalT :: Monad m => NormalT formula v term m a -> m a +runNormalT :: (Monad m, IsLiteral lit, IsFunction (FunOf (TermOf (AtomOf lit)))) => NormalT lit m a -> m a runNormalT action = runLiteralMapM (runSkolemT action) -runNormal :: NormalT formula v term Identity a -> a +runNormal :: (IsLiteral lit, IsFunction (FunOf (TermOf (AtomOf lit)))) => NormalT lit Identity a -> a runNormal = runIdentity . runNormalT - + --type LiteralMap f = LiteralMapT f Identity -type LiteralMapT f = StateT (Int, Map.Map f Int) +type LiteralMapT lit = StateT (Int, Map lit Int) --runLiteralMap :: LiteralMap p a -> a --runLiteralMap action = runIdentity (runLiteralMapM action) @@ -53,21 +53,23 @@ -- literals. One more restriction that is not implied by the type is -- that no literal can appear in both the pos set and the neg set. data ImplicativeForm lit = - INF {neg :: Set.Set lit, pos :: Set.Set lit} + INF {neg :: Set lit, pos :: Set lit} deriving (Eq, Ord, Data, Typeable, Show) -- |A version of MakeINF that takes lists instead of sets, used for -- implementing a more attractive show method. -makeINF' :: (Negatable lit, Ord lit) => [lit] -> [lit] -> ImplicativeForm lit +makeINF' :: (IsLiteral lit, Ord lit) => [lit] -> [lit] -> ImplicativeForm lit makeINF' n p = INF (Set.fromList n) (Set.fromList p) -prettyINF :: (Negatable lit, Ord lit) => (lit -> Doc) -> ImplicativeForm lit -> Doc -prettyINF lit x = cat $ [text "(", hsep (map lit (Set.toList (neg x))), - text ") => (", hsep (map lit (Set.toList (pos x))), text ")"] +prettyINF :: (IsLiteral lit, Ord lit, Pretty lit) => ImplicativeForm lit -> Doc +prettyINF x = parens (hsep (List.map pPrint (Set.toList (neg x)))) <> text " => " <> parens (hsep (List.map pPrint (Set.toList (pos x)))) -prettyProof :: (Negatable lit, Ord lit) => (lit -> Doc) -> Set.Set (ImplicativeForm lit) -> Doc -prettyProof lit p = cat $ [text "["] ++ intersperse (text ", ") (map (prettyINF lit) (Set.toList p)) ++ [text "]"] +prettyProof :: (IsLiteral lit, Ord lit, Pretty lit) => Set (ImplicativeForm lit) -> Doc +prettyProof p = brackets (vcat (punctuate comma (List.map prettyINF (Set.toList p)))) +instance (IsLiteral lit, Ord lit, Pretty lit) => Pretty (ImplicativeForm lit) where + pPrint = prettyINF + -- |Take the clause normal form, and turn it into implicative form, -- where each clauses becomes an (LHS, RHS) pair with the negated -- literals on the LHS and the non-negated literals on the RHS: @@ -88,30 +90,32 @@ -- a | b | c => e -- a | b | c => f -- @ -implicativeNormalForm :: forall m formula atom term v f lit. - (Monad m, - FirstOrderFormula formula atom v, - PropositionalFormula formula atom, - Atom atom term v, - Literal lit atom, - Term term v f, - Data formula, Ord formula, Ord lit, Data lit, Skolem f v) => - formula -> SkolemT v term m (Set.Set (ImplicativeForm lit)) +implicativeNormalForm :: forall m fof pf lit atom term v function. + (IsFirstOrder fof, Ord fof, + IsPropositional pf, + JustLiteral lit, + HasSkolem function, Typeable function, Monad m, + atom ~ AtomOf fof, + pf ~ PFormula atom, + lit ~ LFormula atom, Data lit, + term ~ TermOf atom, + function ~ FunOf term, + v ~ VarOf fof, + v ~ SVarOf function) => + fof -> SkolemT m function (Set (ImplicativeForm lit)) implicativeNormalForm formula = - do cnf <- clauseNormalForm formula - let pairs = Set.map (Set.fold collect (Set.empty, Set.empty)) cnf :: Set.Set (Set.Set lit, Set.Set lit) - pairs' = Set.flatten (Set.map split pairs) :: Set.Set (Set.Set lit, Set.Set lit) - return (Set.map (\ (n,p) -> INF n p) pairs') + do let (cnf :: Set (Set (LFormula atom))) = simpcnf id (runSkolem (skolemize id formula) :: PFormula atom) + pairs = Set.map (Set.fold collect (Set.empty, Set.empty)) cnf + pairs' = Set.flatten (Set.map split pairs) + return (Set.map (uncurry INF) pairs') where - collect :: lit -> (Set.Set lit, Set.Set lit) -> (Set.Set lit, Set.Set lit) collect f (n, p) = foldLiteral (\ f' -> (Set.insert f' n, p)) - (ifElse (n, Set.insert true p) (Set.insert true n, p)) + (bool (Set.insert true n, p) (n, Set.insert true p)) (\ _ -> (n, Set.insert f p)) f - split :: (Set.Set lit, Set.Set lit) -> Set.Set (Set.Set lit, Set.Set lit) split (lhs, rhs) = - if any isSkolem (gFind rhs :: [f]) + if any (foldSkolem (\_ -> False) (\_ _ -> True)) (gFind rhs :: [function]) then Set.map (\ x -> (lhs, Set.singleton x)) rhs else Set.singleton (lhs, rhs) @@ -120,4 +124,4 @@ -- instance, e.g. Maybe Foo will return the first Foo -- found while [Foo] will return the list of Foos found. gFind :: (MonadPlus m, Data a, Typeable b) => a -> m b -gFind = msum . map return . listify (const True) +gFind = msum . List.map return . listify (const True) diff --git a/Data/Logic/Resolution.hs b/Data/Logic/Resolution.hs --- a/Data/Logic/Resolution.hs +++ b/Data/Logic/Resolution.hs @@ -13,24 +13,28 @@ , getSubstAtomEq ) where -import Data.Logic.Classes.Apply (Predicate) +import Data.Logic.ATP.Apply (HasApply(TermOf, PredOf, applyPredicate)) +import Data.Logic.ATP.Equate (HasEquate(equate, foldEquate), zipEquates) +import Data.Logic.ATP.Formulas (fromBool, IsFormula(AtomOf, atomic)) +import Data.Logic.ATP.Lit (foldLiteral, IsLiteral, JustLiteral, zipLiterals) +import Data.Logic.ATP.Term (IsTerm(TVarOf, vt, fApp), foldTerm, zipTerms) import Data.Logic.Classes.Atom (Atom(isRename, getSubst)) -import Data.Logic.Classes.Constants (fromBool) -import Data.Logic.Classes.Equals (AtomEq(foldAtomEq, equals), applyEq, zipAtomsEq) -import Data.Logic.Classes.Formula (Formula(atomic)) -import Data.Logic.Classes.Literal (Literal(..), zipLiterals) -import Data.Logic.Classes.Term (Term(..)) import Data.Logic.Normal.Implicative (ImplicativeForm(INF, neg, pos)) -import qualified Data.Set.Extra as S import Data.Map (Map, empty) -import qualified Data.Map as Map import Data.Maybe (isJust) +import qualified Data.Map as Map +import qualified Data.Set.Extra as S type SetOfSupport lit v term = S.Set (Unification lit v term) type Unification lit v term = (ImplicativeForm lit, Map.Map v term) -prove :: (Literal lit atom, Atom atom term v, Term term v f, Ord lit, Ord term, Ord v, {-Show v, Show term,-} AtomEq atom p term, Predicate p) => +prove :: (atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term, + IsLiteral lit, JustLiteral lit, + Atom atom term v, + IsTerm term, + HasEquate atom, + Ord lit, Ord term, Ord v) => Maybe Int -- ^ Recursion limit. We continue recursing until this -- becomes zero. If it is negative it may recurse until -- it overflows the stack. @@ -56,8 +60,12 @@ -- else -- prove (ss1 ++ [s]) ss' (fst s:kb) -prove' :: forall lit atom p f v term. - (Literal lit atom, Atom atom term v, Term term v f, Ord lit, Ord term, Ord v, AtomEq atom p term, Eq p) => +prove' :: forall lit atom v p term. + (atom ~ AtomOf lit, term ~ TermOf atom, p ~ PredOf atom, v ~ TVarOf term, + IsLiteral lit, JustLiteral lit, + HasEquate atom, + Atom (AtomOf lit) term v, IsTerm term, + Ord lit, Ord term, Ord v, Eq p) => Unification lit v term -> S.Set (ImplicativeForm lit) -> SetOfSupport lit v term -> SetOfSupport lit v term -> (SetOfSupport lit v term, Bool) prove' p kb ss1 ss2 = let @@ -69,7 +77,13 @@ in if S.null ss' then (ss1, False) else (S.union ss1 ss', tf) -getResult :: (Literal lit atom, Atom atom term v, Term term v f, Ord lit, Ord term, Ord v, AtomEq atom p term, Eq p) => +getResult :: (atom ~ AtomOf lit, term ~ TermOf atom, p ~ PredOf atom, v ~ TVarOf term, + IsLiteral lit, + JustLiteral lit, + Atom atom term v, + IsTerm term, + HasEquate atom, + Ord lit, Ord term, Ord v) => SetOfSupport lit v term -> S.Set (Maybe (Unification lit v term)) -> ((SetOfSupport lit v term), Bool) getResult ss us = case S.minView us of @@ -97,20 +111,24 @@ -} -- |Convert the "question" to a set of support. -getSetOfSupport :: (Literal lit atom, Atom atom term v, Term term v f, Ord lit, Ord term, Ord v) => +getSetOfSupport :: (atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term, + IsLiteral lit, JustLiteral lit, Atom atom term v, IsTerm term, Ord lit, Ord term, Ord v) => S.Set (ImplicativeForm lit) -> S.Set (ImplicativeForm lit, Map.Map v term) getSetOfSupport s = S.map (\ x -> (x, getSubsts x empty)) s -getSubsts :: (Literal lit atom, Atom atom term v, Term term v f, Ord lit) => +getSubsts :: (JustLiteral lit, Atom atom term v, IsTerm term, Ord lit, + atom ~ AtomOf lit, v ~ TVarOf term, term ~ TermOf atom) => ImplicativeForm lit -> Map.Map v term -> Map.Map v term -getSubsts inf theta = - getSubstSentences (pos inf) (getSubstSentences (neg inf) theta) +getSubsts inf theta = getSubstSentences (pos inf) (getSubstSentences (neg inf) theta) -getSubstSentences :: (Literal lit atom, Atom atom term v, Term term v f) => S.Set lit -> Map.Map v term -> Map.Map v term +getSubstSentences :: (JustLiteral lit, Atom atom term v, IsTerm term, + atom ~ AtomOf lit, v ~ TVarOf term, term ~ TermOf atom) => + S.Set lit -> Map.Map v term -> Map.Map v term getSubstSentences xs theta = foldr getSubstSentence theta (S.toList xs) -getSubstSentence :: (Literal lit atom, Atom atom term v, Term term v f) => lit -> Map.Map v term -> Map.Map v term +getSubstSentence :: (atom ~ AtomOf lit, v ~ TVarOf term, term ~ TermOf atom, + JustLiteral lit, Atom atom term v, IsTerm term) => lit -> Map.Map v term -> Map.Map v term getSubstSentence formula theta = foldLiteral (\ s -> getSubstSentence s theta) @@ -118,10 +136,11 @@ (getSubst theta) formula -getSubstAtomEq :: forall atom p term v f. (AtomEq atom p term, Term term v f) => Map v term -> atom -> Map v term -getSubstAtomEq theta = foldAtomEq (\ _ ts -> getSubstsTerms ts theta) (const theta) (\ t1 t2 -> getSubstsTerms [t1, t2] theta) +getSubstAtomEq :: forall atom term v. (term ~ TermOf atom, v ~ TVarOf term, + HasEquate atom, IsTerm term) => Map v term -> atom -> Map v term +getSubstAtomEq theta = foldEquate (\ t1 t2 -> getSubstsTerms [t1, t2] theta) (\ _ ts -> getSubstsTerms ts theta) -getSubstsTerms :: Term term v f => [term] -> Map.Map v term -> Map.Map v term +getSubstsTerms :: (v ~ TVarOf term, IsTerm term) => [term] -> Map.Map v term -> Map.Map v term getSubstsTerms [] theta = theta getSubstsTerms (x:xs) theta = let @@ -130,13 +149,14 @@ in theta'' -getSubstsTerm :: Term term v f => term -> Map.Map v term -> Map.Map v term +getSubstsTerm :: (IsTerm term, v ~ TVarOf term) => term -> Map.Map v term -> Map.Map v term getSubstsTerm term theta = foldTerm (\ v -> Map.insertWith (\ _ old -> old) v (vt v) theta) (\ _ ts -> getSubstsTerms ts theta) term -isRenameOf :: (Literal lit atom, Atom atom term v, Term term v f, Ord lit) => +isRenameOf :: (atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term, + IsLiteral lit, JustLiteral lit, Atom atom term v, IsTerm term, Ord lit) => ImplicativeForm lit -> ImplicativeForm lit -> Bool isRenameOf inf1 inf2 = (isRenameOfSentences lhs1 lhs2) && (isRenameOfSentences rhs1 rhs2) @@ -146,31 +166,32 @@ lhs2 = neg inf2 rhs2 = pos inf2 -isRenameOfSentences :: (Literal lit atom, Atom atom term v, Term term v f) => S.Set lit -> S.Set lit -> Bool +isRenameOfSentences :: (atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term, + IsLiteral lit, JustLiteral lit, Atom atom term v, IsTerm term) => S.Set lit -> S.Set lit -> Bool isRenameOfSentences xs1 xs2 = S.size xs1 == S.size xs2 && all (uncurry isRenameOfSentence) (zip (S.toList xs1) (S.toList xs2)) -isRenameOfSentence :: forall lit atom term v f. (Literal lit atom, Atom atom term v, Term term v f) => lit -> lit -> Bool +isRenameOfSentence :: forall lit atom term v. (atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term, + IsLiteral lit, JustLiteral lit, Atom atom term v, IsTerm term) => lit -> lit -> Bool isRenameOfSentence f1 f2 = maybe False id $ zipLiterals (\ _ _ -> Just False) (\ x y -> Just (x == y)) (\ x y -> Just (isRename x y)) f1 f2 -isRenameOfAtomEq :: (AtomEq atom p term, Term term v f) => atom -> atom -> Bool +isRenameOfAtomEq :: (term ~ TermOf atom, HasEquate atom, IsTerm term) => atom -> atom -> Bool isRenameOfAtomEq a1 a2 = maybe False id $ - zipAtomsEq (\ p1 ts1 p2 ts2 -> Just (p1 == p2 && isRenameOfTerms ts1 ts2)) - (\ x y -> Just (x == y)) - (\ t1l t1r t2l t2r -> Just (isRenameOfTerm t1l t2l && isRenameOfTerm t1r t2r)) + zipEquates (\ t1l t1r t2l t2r -> Just (isRenameOfTerm t1l t2l && isRenameOfTerm t1r t2r)) + (\ _ tps -> Just (uncurry isRenameOfTerms (unzip tps))) a1 a2 -isRenameOfTerm :: Term term v f => term -> term -> Bool +isRenameOfTerm :: IsTerm term => term -> term -> Bool isRenameOfTerm t1 t2 = maybe False id $ zipTerms (\ _ _ -> Just True) (\ f1 ts1 f2 ts2 -> Just (f1 == f2 && isRenameOfTerms ts1 ts2)) t1 t2 -isRenameOfTerms :: Term term v f => [term] -> [term] -> Bool +isRenameOfTerms :: IsTerm term => [term] -> [term] -> Bool isRenameOfTerms ts1 ts2 = if length ts1 == length ts2 then let @@ -180,8 +201,13 @@ else False -resolution :: forall lit atom p f term v. (Literal lit atom, Atom atom term v, Term term v f, Eq lit, Ord lit, Eq term, Ord v, AtomEq atom p term, Eq p) => - (ImplicativeForm lit, Map.Map v term) -> (ImplicativeForm lit, Map.Map v term) -> Maybe (ImplicativeForm lit, Map v term) +resolution :: forall lit atom v p term. + (atom ~ AtomOf lit, v ~ TVarOf term, term ~ TermOf atom, p ~ PredOf atom, + IsLiteral lit, JustLiteral lit, + HasEquate atom, + Atom atom term v, IsTerm term, + Eq lit, Ord lit, Eq term, Ord v, Eq p) => + (ImplicativeForm lit, Map.Map v term) -> (ImplicativeForm lit, Map.Map v term) -> Maybe (ImplicativeForm lit, Map v term) resolution (inf1, theta1) (inf2, theta2) = let lhs1 = neg inf1 @@ -202,11 +228,11 @@ Just (INF lhs'' rhs'', theta) Nothing -> Nothing where - tryUnify :: (Literal lit atom, Ord lit) => + tryUnify :: (IsLiteral lit, Ord lit) => S.Set lit -> S.Set lit -> Maybe ((S.Set lit, Map.Map v term), (S.Set lit, Map.Map v term)) tryUnify lhs rhs = tryUnify' lhs rhs S.empty - tryUnify' :: (Literal lit atom, Ord lit) => + tryUnify' :: (IsLiteral lit, Ord lit) => S.Set lit -> S.Set lit -> S.Set lit -> Maybe ((S.Set lit, Map.Map v term), (S.Set lit, Map.Map v term)) tryUnify' lhss _ _ | S.null lhss = Nothing tryUnify' lhss'' rhss lhss' = @@ -216,7 +242,7 @@ Just (rhss', theta1', theta2') -> Just ((S.union lhss' lhss, theta1'), (rhss', theta2')) - tryUnify'' :: (Literal lit atom, Ord lit) => + tryUnify'' :: (IsLiteral lit, JustLiteral lit, Ord lit) => lit -> S.Set lit -> S.Set lit -> Maybe (S.Set lit, Map.Map v term, Map.Map v term) tryUnify'' _x rhss _ | S.null rhss = Nothing tryUnify'' x rhss'' rhss' = @@ -225,13 +251,15 @@ Nothing -> tryUnify'' x rhss (S.insert rhs rhss') Just (theta1', theta2') -> Just (S.union rhss' rhss, theta1', theta2') --- |Try to unify the second argument using the equality in the first. -demodulate :: (Literal lit atom, Atom atom term v, Term term v f, Eq lit, Ord lit, Eq term, Ord v, AtomEq atom p term) => +-- |Try to unify the second argument using the equate in the first. +demodulate :: (JustLiteral lit, HasEquate atom, Atom atom term v, IsTerm term, Eq lit, Ord lit, + atom ~ AtomOf lit, v ~ TVarOf term, term ~ TermOf atom, + Eq term, Ord v) => (Unification lit v term) -> (Unification lit v term) -> Maybe (Unification lit v term) demodulate (inf1, theta1) (inf2, theta2) = case (S.null (neg inf1), S.toList (pos inf1)) of (True, [lit1]) -> - foldLiteral (\ _ -> error "demodulate") (\ _ -> Nothing) (foldAtomEq (\ _ _ -> Nothing) (\ _ -> Nothing) p) lit1 + foldLiteral (\ _ -> error "demodulate") (\ _ -> Nothing) (foldEquate p (\ _ _ -> Nothing)) lit1 _ -> Nothing where p t1 t2 = @@ -248,27 +276,29 @@ rhs2 = pos inf2 -- |Unification: unifies two sentences. -unify :: (Literal lit atom, Atom atom term v, Term term v f, AtomEq atom p term, Eq p) => +unify :: (atom ~ AtomOf lit, v ~ TVarOf term, term ~ TermOf atom, + IsLiteral lit, JustLiteral lit, Atom atom term v, IsTerm term, HasEquate atom) => lit -> lit -> Maybe (Map.Map v term, Map.Map v term) unify s1 s2 = unify' s1 s2 empty empty -unify' :: (Literal lit atom, Atom atom term v, Term term v f, AtomEq atom p term, Eq p) => +unify' :: (atom ~ AtomOf lit, v ~ TVarOf term, term ~ TermOf atom, + IsLiteral lit, JustLiteral lit, Atom atom term v, IsTerm term, HasEquate atom) => lit -> lit -> Map.Map v term -> Map.Map v term -> Maybe (Map.Map v term, Map.Map v term) unify' f1 f2 theta1 theta2 = zipLiterals (\ _ _ -> error "unify'") - (\ x y -> if x == y then unifyTerms [] [] theta1 theta2 else Nothing) + (\ x y -> if x == y then unifyTerms [] theta1 theta2 else Nothing) (unify2AtomsEq theta1 theta2) f1 f2 -unify2AtomsEq :: (AtomEq atom p term, Term term v f) => Map.Map v term -> Map.Map v term -> atom -> atom -> Maybe (Map.Map v term, Map.Map v term) +unify2AtomsEq :: (term ~ TermOf atom, HasEquate atom, IsTerm term, v ~ TVarOf term + ) => Map.Map v term -> Map.Map v term -> atom -> atom -> Maybe (Map.Map v term, Map.Map v term) unify2AtomsEq theta1 theta2 a1 a2 = - zipAtomsEq (\ p1 ts1 p2 ts2 -> if p1 == p2 then unifyTerms ts1 ts2 theta1 theta2 else Nothing) - (\ x y -> if x == y then unifyTerms [] [] theta1 theta2 else Nothing) - (\ l1 r1 l2 r2 -> unifyTerms [l1, r1] [l2, r2] theta1 theta2) + zipEquates (\ l1 r1 l2 r2 -> unifyTerms (zip [l1, r1] [l2, r2]) theta1 theta2) + (\ _ tps -> unifyTerms tps theta1 theta2) a1 a2 -unifyTerm :: Term term v f => term -> term -> Map.Map v term -> Map.Map v term -> Maybe (Map.Map v term, Map.Map v term) +unifyTerm :: (v ~ TVarOf term, IsTerm term) => term -> term -> Map.Map v term -> Map.Map v term -> Maybe (Map.Map v term, Map.Map v term) unifyTerm t1 t2 theta1 theta2 = foldTerm (\ v1 -> @@ -280,21 +310,22 @@ (\ t2' -> unifyTerm t1 t2' theta1 theta2) (Map.lookup v2 theta2)) (\ f2 ts2 -> if f1 == f2 - then unifyTerms ts1 ts2 theta1 theta2 + then unifyTerms (zip ts1 ts2) theta1 theta2 else Nothing) t2) t1 -unifyTerms :: Term term v f => - [term] -> [term] -> Map.Map v term -> Map.Map v term -> Maybe (Map.Map v term, Map.Map v term) -unifyTerms [] [] theta1 theta2 = Just (theta1, theta2) -unifyTerms (t1:ts1) (t2:ts2) theta1 theta2 = +unifyTerms :: (v ~ TVarOf term, IsTerm term) => + [(term, term)] -> Map.Map v term -> Map.Map v term -> Maybe (Map.Map v term, Map.Map v term) +unifyTerms [] theta1 theta2 = Just (theta1, theta2) +unifyTerms ((t1, t2) : tps) theta1 theta2 = case (unifyTerm t1 t2 theta1 theta2) of Nothing -> Nothing - Just (theta1',theta2') -> unifyTerms ts1 ts2 theta1' theta2' -unifyTerms _ _ _ _ = Nothing + Just (theta1',theta2') -> unifyTerms tps theta1' theta2' -findUnify :: forall lit atom term v p f. (Literal lit atom, Atom atom term v, Term term v f, AtomEq atom p term) => +findUnify :: forall lit atom term v. + (JustLiteral lit, Atom atom term v, IsTerm term, HasEquate atom, + atom ~ AtomOf lit, v ~ TVarOf term, term ~ TermOf atom) => term -> term -> S.Set lit -> Maybe ((term, term), Map.Map v term, Map.Map v term) findUnify tl tr s = let @@ -309,13 +340,13 @@ (Nothing:_) -> error "findUnify" where -- getTerms lit = foldLiteral (\ _ -> error "getTerms") p formula - p :: atom -> [term] - p = foldAtomEq (\ _ ts -> concatMap getTerms' ts) (const []) (\ t1 t2 -> getTerms' t1 ++ getTerms' t2) + p :: (AtomOf lit) -> [term] + p = foldEquate (\ t1 t2 -> getTerms' t1 ++ getTerms' t2) (\ _ ts -> concatMap getTerms' ts) getTerms' :: term -> [term] getTerms' t = foldTerm (\ v -> [vt v]) (\ f ts -> fApp f ts : concatMap getTerms' ts) t {- -getTerms :: Literal formula atom v => formula -> [term] +getTerms :: IsLiteral formula atom v => formula -> [term] getTerms formula = foldLiteral (\ _ -> error "getTerms") p formula where @@ -324,17 +355,18 @@ p (Apply _ ts) = concatMap getTerms' ts -} -replaceTerm :: forall lit atom term v p f. (Literal lit atom, Atom atom term v, Term term v f, Eq term, AtomEq atom p term) => lit -> (term, term) -> Maybe lit +replaceTerm :: (JustLiteral lit, Atom atom term v, IsTerm term, Eq term, HasEquate atom, + atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) => + lit -> (term, term) -> Maybe lit replaceTerm formula (tl', tr') = foldLiteral (\ _ -> error "error in replaceTerm") - (\ x -> Just (atomic (applyEq (fromBool x) [] :: atom))) - (foldAtomEq (\ p ts -> Just (atomic (applyEq p (map (\ t -> replaceTerm' t) ts)))) - (\ x -> Just (atomic (applyEq (fromBool x) [] :: atom))) - (\ t1 t2 -> + (\ x -> Just (fromBool x)) + (foldEquate (\ t1 t2 -> let t1' = replaceTerm' t1 t2' = replaceTerm' t2 in - if t1' == t2' then Nothing else Just (atomic (t1' `equals` t2')))) + if t1' == t2' then Nothing else Just (atomic (t1' `equate` t2'))) + (\ p ts -> Just (atomic (applyPredicate p (map (\ t -> replaceTerm' t) ts))))) formula where replaceTerm' t = @@ -342,31 +374,32 @@ then tr' else foldTerm vt (\ f ts -> fApp f (map replaceTerm' ts)) t termEq t1 t2 = - maybe False id (zipTerms (\ v1 v2 -> Just (v1 == v2)) (\ f1 ts1 f2 ts2 -> Just (f1 == f2 && length ts1 == length ts2 && all (uncurry termEq) (zip ts1 ts2))) t1 t2) + maybe False id (zipTerms (\a b -> Just (a == b)) (\ f1 ts1 f2 ts2 -> Just (f1 == f2 && all (uncurry termEq) (zip ts1 ts2))) t1 t2) -subst :: (Literal formula atom, AtomEq atom p term, Atom atom term v, Term term v f, Eq term) => formula -> Map.Map v term -> Maybe formula +subst :: (JustLiteral lit, HasEquate atom, Atom atom term v, IsTerm term, Eq term, + atom ~ AtomOf lit, v ~ TVarOf term, term ~ TermOf atom) => + lit -> Map.Map v term -> Maybe lit subst formula theta = foldLiteral (\ _ -> Just formula) (\ x -> Just (fromBool x)) - (foldAtomEq (\ p ts -> Just (atomic (applyEq p (substTerms ts theta)))) - (Just . fromBool) - (\ t1 t2 -> + (foldEquate (\ t1 t2 -> let t1' = substTerm t1 theta t2' = substTerm t2 theta in - if t1' == t2' then Nothing else Just (atomic (t1' `equals` t2')))) + if t1' == t2' then Nothing else Just (atomic (t1' `equate` t2'))) + (\ p ts -> Just (atomic (applyPredicate p (substTerms ts theta))))) formula -substTerm :: Term term v f => term -> Map.Map v term -> term +substTerm :: (v ~ TVarOf term, IsTerm term) => term -> Map.Map v term -> term substTerm term theta = foldTerm (\ v -> maybe term id (Map.lookup v theta)) (\ f ts -> fApp f (substTerms ts theta)) term -substTerms :: Term term v f => [term] -> Map.Map v term -> [term] +substTerms :: (v ~ TVarOf term, IsTerm term) => [term] -> Map.Map v term -> [term] substTerms ts theta = map (\t -> substTerm t theta) ts -updateSubst :: Term term v f => Map.Map v term -> Map.Map v term -> Map.Map v term +updateSubst :: (v ~ TVarOf term, IsTerm term) => Map.Map v term -> Map.Map v term -> Map.Map v term updateSubst theta1 theta2 = Map.union theta1 (Map.intersection theta1 theta2) -- This is what was in the original code, which behaves slightly differently --updateSubst theta1 _ | Map.null theta1 = Map.empty diff --git a/Data/Logic/Satisfiable.hs b/Data/Logic/Satisfiable.hs --- a/Data/Logic/Satisfiable.hs +++ b/Data/Logic/Satisfiable.hs @@ -1,9 +1,10 @@ --- |Do satisfiability computations on any FirstOrderFormula formula by --- converting it to a convenient instance of PropositionalFormula and --- using the satisfiable function from that instance. Currently we --- use the satisfiable function from the PropLogic package, by the --- Bucephalus project. -{-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes, ScopedTypeVariables #-} +-- | Do satisfiability computations on any FirstOrderFormula formula +-- by converting it to a convenient instance of PropositionalFormula +-- and using the satisfiable function from that instance. Currently +-- we use the satisfiable function from the PropLogic package, by the +-- Bucephalus project - it is much faster than a naive implementation +-- such as Prop.satisfiable. +{-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes, ScopedTypeVariables, TypeFamilies #-} module Data.Logic.Satisfiable ( satisfiable , theorem @@ -11,43 +12,61 @@ , invalid ) where -import qualified Data.Set as Set -import Data.Logic.Classes.Atom (Atom) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), toPropositional) -import Data.Logic.Classes.Literal (Literal) -import Data.Logic.Classes.Negate ((.~.)) -import Data.Logic.Classes.Propositional (PropositionalFormula) -import Data.Logic.Classes.Term (Term) -import Data.Logic.Harrison.Skolem (SkolemT) +import Data.List as List (map) +import Data.Logic.ATP.Apply (HasApply(TermOf, PredOf)) +import Data.Logic.ATP.FOL (IsFirstOrder) +import Data.Logic.ATP.Formulas (IsFormula(AtomOf)) +import Data.Logic.ATP.Lit ((.~.), convertLiteral, LFormula) +import Data.Logic.ATP.Prop (PFormula, simpcnf) +import Data.Logic.ATP.Pretty (HasFixity, Pretty, ) +import Data.Logic.ATP.Quantified (IsQuantified(VarOf)) +import Data.Logic.ATP.Skolem (HasSkolem(SVarOf), runSkolem, skolemize) +import Data.Logic.ATP.Term (IsTerm(FunOf, TVarOf)) import Data.Logic.Instances.PropLogic () -import Data.Logic.Normal.Clause (clauseNormalForm) -import qualified PropLogic as PL +import Data.Set as Set (toList) +import qualified PropLogic as PL -- () -- |Is there any variable assignment that makes the formula true? --- satisfiable :: forall formula atom term v f m. (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f, Ord formula, Literal formula atom v, Ord atom) => +-- satisfiable :: forall formula atom term v f m. (Monad m, IsQuantified formula atom v, Formula atom term v, IsTerm term v f, Ord formula, IsLiteral formula atom v, Ord atom) => -- formula -> SkolemT v term m Bool -satisfiable :: forall m formula atom v term f. (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal formula atom, Term term v f, Atom atom term v, - Ord atom, Monad m, Eq formula, Ord formula) => - formula -> SkolemT v term m Bool +satisfiable :: forall formula atom v term function. + (IsFirstOrder formula, HasSkolem function, Ord formula, + atom ~ AtomOf formula, term ~ TermOf atom, function ~ FunOf term, + v ~ TVarOf term, v ~ SVarOf function) => + formula -> Bool satisfiable f = - do (clauses :: Set.Set (Set.Set formula)) <- clauseNormalForm f - let f' = PL.CJ . map (PL.DJ . map (toPropositional PL.A)) . map Set.toList . Set.toList $ clauses - return . PL.satisfiable $ f' + (PL.satisfiable . PL.CJ . List.map (PL.DJ . List.map convert) . List.map Set.toList . Set.toList . simpcnf id . skolemize') f + where + skolemize' = ((runSkolem . skolemize id) :: formula -> PFormula atom) + convert :: LFormula atom -> PL.PropForm atom + convert = convertLiteral id -- |Is the formula always false? (Not satisfiable.) -inconsistant :: forall m formula atom v term f. (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal formula atom, Term term v f, Atom atom term v, - Ord atom, Monad m, Eq formula, Ord formula) => - formula -> SkolemT v term m Bool -inconsistant f = satisfiable f >>= return . not +inconsistant :: forall formula atom v term p function. + (atom ~ AtomOf formula, term ~ TermOf atom, p ~ PredOf atom, v ~ VarOf formula, v ~ SVarOf function, function ~ FunOf term, + IsFirstOrder formula, + HasSkolem function, + Eq formula, Ord formula, Pretty formula, + Ord atom, Pretty atom, HasFixity atom) => + formula -> Bool +inconsistant f = not (satisfiable f) -- |Is the negation of the formula inconsistant? -theorem :: forall m formula atom v term f. (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal formula atom, Term term v f, Atom atom term v, - Ord atom, Monad m, Eq formula, Ord formula) => - formula -> SkolemT v term m Bool +theorem :: forall formula atom v term p function. + (atom ~ AtomOf formula, term ~ TermOf atom, p ~ PredOf atom, v ~ VarOf formula, v ~ SVarOf function, function ~ FunOf term, + IsFirstOrder formula, + HasSkolem function, + Eq formula, Ord formula, Pretty formula, + Ord atom, Pretty atom, HasFixity atom) => + formula -> Bool theorem f = inconsistant ((.~.) f) -- |A formula is invalid if it is neither a theorem nor inconsistent. -invalid :: forall m formula atom v term f. (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal formula atom, Term term v f, Atom atom term v, - Ord atom, Monad m, Eq formula, Ord formula) => - formula -> SkolemT v term m Bool -invalid f = inconsistant f >>= \ fi -> theorem f >>= \ ft -> return (not (fi || ft)) +invalid :: forall formula atom v term p function. + (atom ~ AtomOf formula, term ~ TermOf atom, p ~ PredOf atom, v ~ VarOf formula, v ~ SVarOf function, function ~ FunOf term, + IsFirstOrder formula, + HasSkolem function, + Eq formula, Ord formula, Pretty formula, + Ord atom, Pretty atom, HasFixity atom) => + formula -> Bool +invalid f = not (inconsistant f || theorem f) diff --git a/Data/Logic/Tests/Main.hs b/Data/Logic/Tests/Main.hs deleted file mode 100644 --- a/Data/Logic/Tests/Main.hs +++ /dev/null @@ -1,26 +0,0 @@ -import Common (TestFormula, TestProof, V, TFormula, TAtom, TTerm) -import System.Exit -import Test.HUnit -import qualified Data.Logic.Harrison.DP as DP -import qualified Data.Logic.Harrison.PropExamples as PropExamples -import qualified Harrison.Main as Harrison -import qualified Logic -import qualified Chiou0 as Chiou0 ---import qualified Data.Logic.Tests.TPTP as TPTP -import qualified Data - -main :: IO () -main = - runTestTT (TestList [Logic.tests, - Chiou0.tests, - -- TPTP.tests, -- This has a problem in the rendering code - it loops - Data.tests formulas proofs, - Harrison.tests, - PropExamples.tests, - DP.tests]) >>= - doCounts - where - doCounts counts' = exitWith (if errors counts' /= 0 || failures counts' /= 0 then ExitFailure 1 else ExitSuccess) - -- Generate the test data with a particular instantiation of FirstOrderFormula. - formulas = (Data.allFormulas :: [TestFormula TFormula TAtom V]) - proofs = (Data.proofs :: [TestProof TFormula TTerm V]) diff --git a/Data/Logic/Types/Common.hs b/Data/Logic/Types/Common.hs deleted file mode 100644 --- a/Data/Logic/Types/Common.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} -module Data.Logic.Types.Common where - -import Data.Logic.Classes.Variable (Variable(..)) -import qualified Data.Set as Set -import Text.PrettyPrint (text) - -instance Variable String where - variant x vars = if Set.member x vars then variant (x ++ "'") vars else x - prefix p x = p ++ x - prettyVariable = text - -{- -instance Variable String where - variant v vs = - if Set.member v vs then variant (next v) (Set.insert v vs) else v - where - next :: String -> String - next s = - case break (not . isDigit) (reverse s) of - (_, "") -> "x" - ("", nondigits) -> nondigits ++ "2" - (digits, nondigits) -> nondigits ++ show (1 + read (reverse digits) :: Int) --} diff --git a/Data/Logic/Types/FirstOrder.hs b/Data/Logic/Types/FirstOrder.hs --- a/Data/Logic/Types/FirstOrder.hs +++ b/Data/Logic/Types/FirstOrder.hs @@ -1,220 +1,184 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, - GeneralizedNewtypeDeriving, MultiParamTypeClasses, TemplateHaskell, TypeFamilies, UndecidableInstances #-} -{-# OPTIONS -fno-warn-missing-signatures -fno-warn-orphans #-} --- |Data types which are instances of the Logic type class for use --- when you just want to use the classes and you don't have a --- particular representation you need to use. +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, TypeFamilies, UndecidableInstances #-} + module Data.Logic.Types.FirstOrder - ( Formula(..) - , PTerm(..) - , Predicate(..) + ( withUnivQuants + , NFormula(..) + , NTerm(..) + , NPredicate(..) ) where import Data.Data (Data) -import qualified Data.Logic.Classes.Apply as C -import qualified Data.Logic.Classes.Atom as C -import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..)) -import Data.Logic.Classes.Constants (Constants(..), asBool) -import Data.Logic.Classes.Equals (AtomEq(..), (.=.), pApp, substAtomEq, varAtomEq, prettyAtomEq) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), Quant(..), prettyFirstOrder, fixityFirstOrder, foldAtomsFirstOrder, mapAtomsFirstOrder) -import qualified Data.Logic.Classes.Formula as C -import Data.Logic.Classes.Literal (Literal(..)) -import Data.Logic.Classes.Negate (Negatable(..)) -import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), botFixity) -import Data.Logic.Classes.Term (Term(..), Function) -import Data.Logic.Classes.Variable (Variable(..)) -import Data.Logic.Classes.Propositional (PropositionalFormula(..)) -import Data.Logic.Harrison.Resolution (matchAtomsEq) -import Data.Logic.Harrison.Tableaux (unifyAtomsEq) -import Data.Logic.Resolution (isRenameOfAtomEq, getSubstAtomEq) -import Data.SafeCopy (SafeCopy, base, deriveSafeCopy, extension, MigrateFrom(..)) +import Data.Logic.ATP.Apply (HasApply(..), IsPredicate, prettyApply) +import Data.Logic.ATP.Equate (associativityEquate, HasEquate(equate, foldEquate), overtermsEq, ontermsEq, precedenceEquate, prettyEquate) +import Data.Logic.ATP.FOL (IsFirstOrder) +import Data.Logic.ATP.Formulas (IsAtom, IsFormula(..)) +import Data.Logic.ATP.Lit (IsLiteral(..)) +import Data.Logic.ATP.Pretty (HasFixity(..), Pretty(pPrint, pPrintPrec), Side(Top)) +import Data.Logic.ATP.Prop (BinOp(..), IsPropositional(..)) +import Data.Logic.ATP.Quantified (associativityQuantified, exists, IsQuantified(..), precedenceQuantified, prettyQuantified, Quant(..)) +import Data.Logic.ATP.Term (IsFunction, IsTerm(..), IsVariable(..), prettyTerm, V) +import Data.SafeCopy (base, deriveSafeCopy) +import Data.String (IsString(fromString)) import Data.Typeable (Typeable) +-- | Examine the formula to find the list of outermost universally +-- quantified variables, and call a function with that list and the +-- formula after the quantifiers are removed. +withUnivQuants :: IsQuantified formula => ([VarOf formula] -> formula -> r) -> formula -> r +withUnivQuants fn formula = + doFormula [] formula + where + doFormula vs f = + foldQuantified + (doQuant vs) + (\ _ _ _ -> fn (reverse vs) f) + (\ _ -> fn (reverse vs) f) + (\ _ -> fn (reverse vs) f) + (\ _ -> fn (reverse vs) f) + f + doQuant vs (:!:) v f = doFormula (v : vs) f + doQuant vs (:?:) v f = fn (reverse vs) (exists v f) + -- | The range of a formula is {True, False} when it has no free variables. -data Formula v p f - = Predicate (Predicate p (PTerm v f)) - | Combine (Combination (Formula v p f)) - | Quant Quant v (Formula v p f) +data NFormula v p f + = Predicate (NPredicate p (NTerm v f)) + | Combine (NFormula v p f) BinOp (NFormula v p f) + | Negate (NFormula v p f) + | Quant Quant v (NFormula v p f) + | TT + | FF -- Note that a derived Eq instance is not going to tell us that -- a&b is equal to b&a, let alone that ~(a&b) equals (~a)|(~b). - deriving (Eq, Ord, Data, Typeable, Show, Read) + deriving (Eq, Ord, Data, Typeable, Show) -- |A temporary type used in the fold method to represent the -- combination of a predicate and its arguments. This reduces the -- number of arguments to foldFirstOrder and makes it easier to manage the -- mapping of the different instances to the class methods. -data Predicate p term +data NPredicate p term = Equal term term | Apply p [term] - deriving (Eq, Ord, Data, Typeable, Show, Read) + deriving (Eq, Ord, Data, Typeable, Show) -- | The range of a term is an element of a set. -data PTerm v f - = Var v -- ^ A variable, either free or +data NTerm v f + = NVar v -- ^ A variable, either free or -- bound by an enclosing quantifier. - | FunApp f [PTerm v f] -- ^ Function application. + | FunApp f [NTerm v f] -- ^ Function application. -- Constants are encoded as -- nullary functions. The result -- is another term. - deriving (Eq, Ord, Data, Typeable, Show, Read) - -instance Negatable (Formula v p f) where - negatePrivate x = Combine ((:~:) x) - foldNegation normal inverted (Combine ((:~:) x)) = foldNegation inverted normal x - foldNegation normal _ x = normal x + deriving (Eq, Ord, Data, Typeable, Show) -instance Constants p => Constants (Formula v p f) where - fromBool = Predicate . fromBool - asBool (Predicate x) = asBool x - asBool _ = Nothing +instance IsVariable v => IsString (NTerm v f) where + fromString = NVar . fromString +instance (IsVariable v, Pretty v, IsFunction f, Pretty f) => Pretty (NTerm v f) where + pPrintPrec = prettyTerm +instance (IsPredicate p, IsTerm term) => HasFixity (NPredicate p term) where + precedence = precedenceEquate + associativity = associativityEquate +instance (IsPredicate p, IsTerm term) => IsAtom (NPredicate p term) +instance HasFixity (NTerm v f) where -instance Constants p => Constants (Predicate p (PTerm v f)) where +instance (IsVariable v, IsPredicate p, IsFunction f, atom ~ NPredicate p (NTerm v f), Pretty atom + ) => IsPropositional (NFormula v p f) where + foldPropositional' ho _ _ _ _ fm@(Quant _ _ _) = ho fm + foldPropositional' _ co _ _ _ (Combine x op y) = co x op y + foldPropositional' _ _ ne _ _ (Negate x) = ne x + foldPropositional' _ _ _ tf _ TT = tf True + foldPropositional' _ _ _ tf _ FF = tf False + foldPropositional' _ _ _ _ at (Predicate x) = at x + a .|. b = Combine a (:|:) b + a .&. b = Combine a (:&:) b + a .=>. b = Combine a (:=>:) b + a .<=>. b = Combine a (:<=>:) b + foldCombination = error "FIXME foldCombination" +instance (IsVariable v, IsPredicate p, IsFunction f) => HasFixity (NFormula v p f) where + precedence = precedenceQuantified + associativity = associativityQuantified +--instance (IsVariable v, IsPredicate p, IsFunction f) => Pretty (NPredicate p (NTerm v f)) where +-- pPrint p = foldEquate prettyEquate prettyApply p +instance (IsPredicate p, IsTerm term) => Pretty (NPredicate p term) where + pPrintPrec d r = foldEquate (prettyEquate d r) prettyApply +instance (IsVariable v, IsPredicate p, IsFunction f) => Pretty (NFormula v p f) where + pPrintPrec = prettyQuantified Top +instance (IsPredicate p, IsTerm term) => HasApply (NPredicate p term) where + type PredOf (NPredicate p term) = p + type TermOf (NPredicate p term) = term + applyPredicate = Apply + foldApply' _ f (Apply p ts) = f p ts + foldApply' d _ x = d x + overterms = overtermsEq + onterms = ontermsEq +instance (IsPredicate p, IsTerm term) => HasEquate (NPredicate p term) where + equate = Equal + foldEquate eq _ (Equal t1 t2) = eq t1 t2 + foldEquate _ ap (Apply p ts) = ap p ts +{- +instance HasBoolean p => HasBoolean (NPredicate p (NTerm v f)) where fromBool x = Apply (fromBool x) [] - asBool (Apply p _) = asBool p + asBool (Apply p []) = asBool p asBool _ = Nothing - -instance (Constants (Formula v p f) {-, Ord v, Ord p, Ord f-}) => Combinable (Formula v p f) where - x .<=>. y = Combine (BinOp x (:<=>:) y) - x .=>. y = Combine (BinOp x (:=>:) y) - x .|. y = Combine (BinOp x (:|:) y) - x .&. y = Combine (BinOp x (:&:) y) - -instance (C.Predicate p, Function f v) => C.Formula (Formula v p f) (Predicate p (PTerm v f)) where - atomic = Predicate - foldAtoms = foldAtomsFirstOrder - mapAtoms = mapAtomsFirstOrder - -instance (C.Formula (Formula v p f) (Predicate p (PTerm v f)), Variable v, C.Predicate p, Function f v, Constants (Formula v p f), Combinable (Formula v p f) - ) => PropositionalFormula (Formula v p f) (Predicate p (PTerm v f)) where - foldPropositional co tf at formula = - maybe testFm tf (asBool formula) - where - testFm = - case formula of - Quant _ _ _ -> error "foldF0: quantifiers should not be present" - Combine x -> co x - Predicate x -> at x - -instance (Variable v, Function f v) => Term (PTerm v f) v f where - foldTerm vf fn t = - case t of - Var v -> vf v - FunApp f ts -> fn f ts - zipTerms v f t1 t2 = - case (t1, t2) of - (Var v1, Var v2) -> v v1 v2 - (FunApp f1 ts1, FunApp f2 ts2) -> f f1 ts1 f2 ts2 - _ -> Nothing - vt = Var - fApp x args = FunApp x args - -{- -instance (Arity p, Constants p) => Atom (Predicate p (PTerm v f)) p (PTerm v f) where - foldAtom ap (Apply p ts) = ap p ts - foldAtom ap (Constant x) = ap (fromBool x) [] - foldAtom _ _ = error "foldAtom Predicate" - zipAtoms ap (Apply p1 ts1) (Apply p2 ts2) = ap p1 ts1 p2 ts2 - zipAtoms ap (Constant x) (Constant y) = ap (fromBool x) [] (fromBool y) [] - zipAtoms _ _ _ = error "zipAtoms Predicate" - apply' = Apply -} - -instance C.Predicate p => AtomEq (Predicate p (PTerm v f)) p (PTerm v f) where - foldAtomEq ap tf _ (Apply p ts) = maybe (ap p ts) tf (asBool p) - foldAtomEq _ _ eq (Equal t1 t2) = eq t1 t2 - equals = Equal - applyEq' = Apply - -instance (C.Formula (Formula v p f) (Predicate p (PTerm v f)), - AtomEq (Predicate p (PTerm v f)) p (PTerm v f), - Constants (Formula v p f), - Variable v, C.Predicate p, Function f v - ) => FirstOrderFormula (Formula v p f) (Predicate p (PTerm v f)) v where - for_all v x = Quant Forall v x - exists v x = Quant Exists v x - foldFirstOrder qu co tf at f = - maybe testFm tf (asBool f) - where testFm = case f of - Quant op v f' -> qu op v f' - Combine x -> co x - Predicate x -> at x -{- - zipFirstOrder qu co tf at f1 f2 = - case (f1, f2) of - (Quant q1 v1 f1', Quant q2 v2 f2') -> qu q1 v1 (Quant q1 v1 f1') q2 v2 (Quant q2 v2 f2') - (Combine x, Combine y) -> co x y - (Predicate x, Predicate y) -> at x y - _ -> Nothing - -instance (Constants (Formula v p f), - Variable v, Ord v, Data v, Show v, - Arity p, Constants p, Ord p, Data p, Show p, - Skolem f, Ord f, Data f, Show f) => Literal (Formula v p f) (Predicate p (PTerm v f)) v where - foldLiteral co tf at l = - case l of - (Combine ((:~:) x)) -> co x - (Predicate p) -> at p - _ -> error "Literal (Formula v p f)" +instance (IsVariable v, IsPredicate p, IsFunction f + ) => IsFormula (NFormula v p f) where + type AtomOf (NFormula v p f) = NPredicate p (NTerm v f) atomic = Predicate + onatoms f (Negate fm) = Negate (onatoms f fm) + onatoms _ TT = TT + onatoms _ FF = FF + onatoms f (Combine lhs op rhs) = Combine (onatoms f lhs) op (onatoms f rhs) + onatoms f (Quant op v fm) = Quant op v (onatoms f fm) + onatoms f (Predicate p) = Predicate (f p) + overatoms f (Negate fm) b = overatoms f fm b + overatoms _ TT b = b + overatoms _ FF b = b + overatoms f (Combine lhs _ rhs) b = overatoms f lhs (overatoms f rhs b) + overatoms f (Quant _ _ fm) b = overatoms f fm b + overatoms f (Predicate p) b = f p b + asBool TT = Just True + asBool FF = Just False + asBool _ = Nothing + true = TT + false = FF +instance (IsVariable v, IsPredicate p, IsFunction f + , atom ~ NPredicate p (NTerm v f) -- , Pretty atom + ) => IsQuantified (NFormula v p f) where + type VarOf (NFormula v p f) = v + foldQuantified qu _ _ _ _ (Quant op v fm) = qu op v fm + foldQuantified _ co ne tf at fm = foldPropositional' (error "FIXME - need other function in case of embedded quantifiers") co ne tf at fm + quant = Quant +instance (IsVariable v, IsPredicate p, IsFunction f + , atom ~ NPredicate p (NTerm v f) -- , Pretty atom + ) => IsLiteral (NFormula v p f) where + foldLiteral' ho ne _tf at fm = + case fm of + Negate fm' -> ne fm' + Predicate x -> at x + _ -> ho fm + naiveNegate = Negate + foldNegation _ ne (Negate x) = ne x + foldNegation other _ fm = other fm +{- +instance (IsPredicate p, IsVariable v, IsFunction f, IsAtom (NPredicate p (NTerm v f)) + ) => HasEquate (NPredicate p (NTerm v f)) p (NTerm v f) where + overterms = overtermsEq + onterms = ontermsEq -} - -instance (Constants p, Ord v, Ord p, Ord f, Constants (Predicate p (PTerm v f)), C.Formula (Formula v p f) (Predicate p (PTerm v f)) - ) => Literal (Formula v p f) (Predicate p (PTerm v f)) where - foldLiteral neg tf at f = - case f of - Quant _ _ _ -> error "Invalid literal" - Combine ((:~:) p) -> neg p - Combine _ -> error "Invalid literal" - Predicate p -> if p == fromBool True - then tf True - else if p == fromBool False - then tf False - else at p - -instance (C.Predicate p, Variable v, Function f v) => C.Atom (Predicate p (PTerm v f)) (PTerm v f) v where - substitute = substAtomEq - freeVariables = varAtomEq - allVariables = varAtomEq - unify = unifyAtomsEq - match = matchAtomsEq - foldTerms f r (Apply _ ts) = foldr f r ts - foldTerms f r (Equal t1 t2) = f t2 (f t1 r) - isRename = isRenameOfAtomEq - getSubst = getSubstAtomEq - -instance (Variable v, Pretty v, - C.Predicate p, Pretty p, - Function f v, Pretty f) => Pretty (Predicate p (PTerm v f)) where - pretty atom = prettyAtomEq pretty pretty pretty 0 atom - -instance (C.Formula (Formula v p f) (Predicate p (PTerm v f)), - C.Predicate p, Variable v, Function f v, HasFixity (Predicate p (PTerm v f))) => HasFixity (Formula v p f) where - fixity = fixityFirstOrder - -instance (C.Formula (Formula v p f) (Predicate p (PTerm v f)), Variable v, C.Predicate p, Function f v) => Pretty (Formula v p f) where - pretty f = prettyFirstOrder (\ _ -> pretty) pretty 0 $ f - -instance HasFixity (Predicate p term) where - fixity = const botFixity - -$(deriveSafeCopy 1 'base ''PTerm) -$(deriveSafeCopy 1 'base ''Formula) -$(deriveSafeCopy 2 'extension ''Predicate) - --- Migration -- - -data Predicate_v1 p term - = Equal_v1 term term - | NotEqual_v1 term term - | Constant_v1 Bool - | Apply_v1 p [term] - deriving (Eq, Ord, Data, Typeable, Show, Read) +instance (IsVariable v, IsPredicate p, IsFunction f, IsAtom (NPredicate p (NTerm v f)) + ) => IsFirstOrder (NFormula v p f) -$(deriveSafeCopy 1 'base ''Predicate_v1) +instance (IsVariable v, IsFunction f) => IsTerm (NTerm v f) where + type TVarOf (NTerm v f) = v + type FunOf (NTerm v f) = f + vt = NVar + fApp = FunApp + foldTerm vf _ (NVar v) = vf v + foldTerm _ ff (FunApp f ts) = ff f ts -instance (SafeCopy p, SafeCopy term) => Migrate (Predicate p term) where - type MigrateFrom (Predicate p term) = (Predicate_v1 p term) - migrate (Equal_v1 t1 t2) = Equal t1 t2 - migrate (Apply_v1 p ts) = Apply p ts - migrate (NotEqual_v1 _ _) = error "Failure migrating Predicate NotEqual" - migrate (Constant_v1 _) = error "Failure migrating Predicate Constant" +$(deriveSafeCopy 1 'base ''BinOp) +$(deriveSafeCopy 1 'base ''Quant) +$(deriveSafeCopy 1 'base ''NFormula) +$(deriveSafeCopy 1 'base ''NPredicate) +$(deriveSafeCopy 1 'base ''NTerm) +$(deriveSafeCopy 1 'base ''V) diff --git a/Data/Logic/Types/FirstOrderPublic.hs b/Data/Logic/Types/FirstOrderPublic.hs --- a/Data/Logic/Types/FirstOrderPublic.hs +++ b/Data/Logic/Types/FirstOrderPublic.hs @@ -1,5 +1,17 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving, - MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TemplateHaskell, UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS -Wwarn -fno-warn-orphans #-} -- |An instance of FirstOrderFormula which implements Eq and Ord by comparing -- after conversion to normal form. This helps us notice that formula which @@ -7,110 +19,109 @@ -- commutative operator. module Data.Logic.Types.FirstOrderPublic - ( Formula(..) - , Bijection(..) + ( PFormula + -- , Bijection(..) + , Marked(Mark, unMark') + , Public + , markPublic + , unmarkPublic ) where import Data.Data (Data) -import Data.Logic.Classes.Apply (Predicate) -import Data.Logic.Classes.Combine (Combinable(..), Combination(..)) -import Data.Logic.Classes.Constants (Constants(..)) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), prettyFirstOrder, foldAtomsFirstOrder, mapAtomsFirstOrder, fixityFirstOrder) -import qualified Data.Logic.Classes.Formula as C -import Data.Logic.Classes.Negate (Negatable(..)) -import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(fixity)) -import Data.Logic.Classes.Propositional (PropositionalFormula(..)) -import Data.Logic.Classes.Term (Function) -import Data.Logic.Classes.Variable (Variable) -import Data.Logic.Normal.Implicative (implicativeNormalForm, ImplicativeForm, runNormal) +import Data.Generics (Typeable) +import Data.Logic.ATP.Apply (IsPredicate) +import Data.Logic.ATP.Formulas (IsAtom, IsFormula(..)) +import Data.Logic.ATP.FOL (IsFirstOrder) +import Data.Logic.ATP.Lit (IsLiteral(..)) +import Data.Logic.ATP.Pretty (HasFixity(..), Pretty(..)) +import Data.Logic.ATP.Prop (IsPropositional(..)) +import Data.Logic.ATP.Quantified (IsQuantified(..)) +import Data.Logic.ATP.Skolem (simpcnf') +import Data.Logic.ATP.Term (IsFunction, IsVariable) import qualified Data.Logic.Types.FirstOrder as N import Data.SafeCopy (base, deriveSafeCopy) import Data.Set (Set) -import Data.Typeable (Typeable) --- |Convert between the public and internal representations. -class Bijection p i where - public :: i -> p - intern :: p -> i +data Marked mark a = Mark {unMark' :: a} deriving (Data, Typeable, Read) --- |The new Formula type is just a wrapper around the Native instance --- (which eventually should be renamed the Internal instance.) No --- derived Eq or Ord instances. -data Formula v p f = Formula {unFormula :: N.Formula v p f} deriving (Data, Typeable, Show) +instance (IsQuantified formula, IsPropositional (Marked mk formula)) => IsQuantified (Marked mk formula) where + type VarOf (Marked mk formula) = VarOf formula + quant q v x = Mark $ quant q v (unMark' x) + foldQuantified qu co ne tf at f = foldQuantified qu' co' ne' tf at (unMark' f) + where qu' op v f' = qu op v (Mark f') + ne' x = ne (Mark x) + co' x op y = co (Mark x) op (Mark y) -instance Bijection (Formula v p f) (N.Formula v p f) where - public = Formula - intern = unFormula +instance IsFirstOrder formula => IsFirstOrder (Marked mk formula) -instance Bijection (Combination (Formula v p f)) (Combination (N.Formula v p f)) where - public (BinOp x op y) = BinOp (public x) op (public y) - public ((:~:) x) = (:~:) (public x) - intern (BinOp x op y) = BinOp (intern x) op (intern y) - intern ((:~:) x) = (:~:) (intern x) +instance IsFormula formula => IsFormula (Marked mk formula) where + type AtomOf (Marked mk formula) = AtomOf formula + atomic = Mark . atomic + overatoms at (Mark fm) = overatoms at fm + onatoms at (Mark fm) = Mark (onatoms at fm) + asBool (Mark x) = asBool x + true = Mark true + false = Mark false -instance Negatable (Formula v p f) where - negatePrivate = Formula . negatePrivate . unFormula - foldNegation normal inverted = foldNegation (normal . Formula) (inverted . Formula) . unFormula +instance IsLiteral formula => IsLiteral (Marked mk formula) where + foldLiteral' ho ne tf at (Mark x) = foldLiteral' (ho . Mark) (ne . Mark) tf at x + naiveNegate (Mark x) = Mark (naiveNegate x) + foldNegation ot ne (Mark x) = foldNegation (ot . Mark) (ne . Mark) x -instance (Constants (N.Formula v p f), Predicate p, Variable v, Function f v) => Constants (Formula v p f) where - fromBool = Formula . fromBool - asBool = asBool . unFormula +instance HasFixity formula => HasFixity (Marked mk formula) where + precedence (Mark x) = precedence x + associativity (Mark x) = associativity x -instance (C.Formula (N.Formula v p f) (N.Predicate p (N.PTerm v f)), - Constants (Formula v p f), - Constants (N.Formula v p f), - Variable v, Predicate p, Function f v) => Combinable (Formula v p f) where - x .<=>. y = Formula $ (unFormula x) .<=>. (unFormula y) - x .=>. y = Formula $ (unFormula x) .=>. (unFormula y) - x .|. y = Formula $ (unFormula x) .|. (unFormula y) - x .&. y = Formula $ (unFormula x) .&. (unFormula y) +instance Pretty formula => Pretty (Marked mk formula) where + pPrint = pPrint . unMark' -instance (Predicate p, Function f v) => C.Formula (Formula v p f) (N.Predicate p (N.PTerm v f)) where - atomic = Formula . C.atomic - foldAtoms = foldAtomsFirstOrder - mapAtoms = mapAtomsFirstOrder +instance IsPropositional formula => IsPropositional (Marked mk formula) where + foldPropositional' ho co ne tf at (Mark x) = foldPropositional' (ho . Mark) co' (ne . Mark) tf at x + where + co' lhs op rhs = co (Mark lhs) op (Mark rhs) + (Mark a) .|. (Mark b) = Mark (a .|. b) + (Mark a) .&. (Mark b) = Mark (a .&. b) + (Mark a) .=>. (Mark b) = Mark (a .=>. b) + (Mark a) .<=>. (Mark b) = Mark (a .<=>. b) + foldCombination other dj cj imp iff fm = + foldCombination (\a -> other a) + (\a b -> dj a b) + (\a b -> cj a b) + (\a b -> imp a b) + (\a b -> iff a b) + fm -instance (C.Formula (Formula v p f) (N.Predicate p (N.PTerm v f)), - C.Formula (N.Formula v p f) (N.Predicate p (N.PTerm v f)), - Variable v, Predicate p, Function f v) => FirstOrderFormula (Formula v p f) (N.Predicate p (N.PTerm v f)) v where - for_all v x = public $ for_all v (intern x :: N.Formula v p f) - exists v x = public $ exists v (intern x :: N.Formula v p f) - foldFirstOrder qu co tf at f = foldFirstOrder qu' co' tf at (intern f :: N.Formula v p f) - where qu' quant v form = qu quant v (public form) - co' x = co (public x) +-- |The new Formula type is just a wrapper around the Native instance +-- (which eventually should be renamed the Internal instance.) No +-- derived Eq or Ord instances, we define them below. +type PFormula v p f = Marked Public (N.NFormula v p f) +data Public = Public -instance (C.Formula (Formula v p f) (N.Predicate p (N.PTerm v f)), - C.Formula (N.Formula v p f) (N.Predicate p (N.PTerm v f)), - Show v, Show p, Show f, HasFixity (Formula v p f), Variable v, Predicate p, - Function f v) => PropositionalFormula (Formula v p f) (N.Predicate p (N.PTerm v f)) where - foldPropositional co tf at f = foldPropositional co' tf at (intern f :: N.Formula v p f) - where co' x = co (public x) +deriving instance Data Public --- |Here are the magic Ord and Eq instances -instance (C.Formula (Formula v p f) (N.Predicate p (N.PTerm v f)), - C.Formula (N.Formula v p f) (N.Predicate p (N.PTerm v f)), - Predicate p, Function f v, Variable v) => Ord (Formula v p f) where +markPublic :: a -> Marked Public a +markPublic = Mark + +unmarkPublic :: Marked Public a -> a +unmarkPublic = unMark' + +instance Show formula => Show (Marked Public formula) where + show (Mark fm) = "markPublic (" ++ show fm ++ ")" + +-- | Here are the magic Ord and Eq instances - formulas will be Eq if +-- their normal forms are Eq up to renaming. +instance (IsAtom (N.NPredicate p (N.NTerm v f)), IsVariable v, Data v, IsPredicate p, Data p, IsFunction f, Data f + ) => Ord (PFormula v p f) where compare a b = - let (a' :: Set (ImplicativeForm (N.Formula v p f))) = runNormal (implicativeNormalForm (unFormula a)) - (b' :: Set (ImplicativeForm (N.Formula v p f))) = runNormal (implicativeNormalForm (unFormula b)) in + let (a' :: Set (Set (N.NFormula v p f))) = simpcnf' (unmarkPublic a) + (b' :: Set (Set (N.NFormula v p f))) = simpcnf' (unmarkPublic b) in case compare a' b' of EQ -> EQ x -> {- if isRenameOf a' b' then EQ else -} x -instance (C.Formula (Formula v p f) (N.Predicate p (N.PTerm v f)), - C.Formula (N.Formula v p f) (N.Predicate p (N.PTerm v f)), - Predicate p, Function f v, Variable v, Constants (N.Predicate p (N.PTerm v f)), - FirstOrderFormula (Formula v p f) (N.Predicate p (N.PTerm v f)) v) => Eq (Formula v p f) where +instance (IsAtom (N.NPredicate p (N.NTerm v f)), IsVariable v, Data v, IsPredicate p, Data p, IsFunction f, Data f + ) => Eq (PFormula v p f) where a == b = compare a b == EQ -instance (Predicate p, Function f v) => HasFixity (Formula v p f) where - fixity = fixityFirstOrder - -instance (C.Formula (Formula v p f) (N.Predicate p (N.PTerm v f)), - C.Formula (N.Formula v p f) (N.Predicate p (N.PTerm v f)), - Pretty v, Show v, Variable v, - Pretty p, Show p, Predicate p, - Pretty f, Show f, Function f v) => Pretty (Formula v p f) where - pretty formula = prettyFirstOrder (\ _prec a -> pretty a) pretty 0 formula - -$(deriveSafeCopy 1 'base ''Formula) +$(deriveSafeCopy 1 'base ''Marked) +$(deriveSafeCopy 1 'base ''Public) diff --git a/Data/Logic/Types/Harrison/Equal.hs b/Data/Logic/Types/Harrison/Equal.hs deleted file mode 100644 --- a/Data/Logic/Types/Harrison/Equal.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances #-} -{-# OPTIONS_GHC -Wall #-} -module Data.Logic.Types.Harrison.Equal where - --- ========================================================================= --- First order logic with equality. --- --- Copyright (co) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) --- ========================================================================= - -import Data.Generics (Data, Typeable) -import Data.List (intersperse) -import Data.Logic.Classes.Apply (Apply(..), Predicate) -import Data.Logic.Classes.Arity (Arity(..)) -import qualified Data.Logic.Classes.Atom as C -import Data.Logic.Classes.Combine (Combination(..), BinOp(..)) -import Data.Logic.Classes.Constants (Constants(fromBool), asBool) -import Data.Logic.Classes.Equals (AtomEq(..), showFirstOrderFormulaEq, substAtomEq, varAtomEq) -import Data.Logic.Classes.FirstOrder (fixityFirstOrder, mapAtomsFirstOrder, foldAtomsFirstOrder) -import qualified Data.Logic.Classes.Formula as C -import Data.Logic.Classes.Literal (Literal(..)) -import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), Fixity(..), FixityDirection(..)) -import qualified Data.Logic.Classes.Propositional as P -import Data.Logic.Harrison.Resolution (matchAtomsEq) -import Data.Logic.Harrison.Tableaux (unifyAtomsEq) -import Data.Logic.Resolution (isRenameOfAtomEq, getSubstAtomEq) -import Data.Logic.Types.Harrison.FOL (TermType(..)) -import Data.Logic.Types.Harrison.Formulas.FirstOrder (Formula(..)) -import Data.String (IsString(..)) -import Text.PrettyPrint (text, cat) - -data FOLEQ = EQUALS TermType TermType | R String [TermType] deriving (Eq, Ord, Show) -data PredName = (:=:) | Named String deriving (Eq, Ord, Show, Data, Typeable) - -instance Arity PredName where - arity (:=:) = Just 2 - arity _ = Nothing - -instance Show (Formula FOLEQ) where - show = showFirstOrderFormulaEq - -instance HasFixity FOLEQ where - fixity (EQUALS _ _) = Fixity 5 InfixL - fixity _ = Fixity 10 InfixN - -instance IsString PredName where - fromString "=" = (:=:) - fromString s = Named s - -instance Constants PredName where - fromBool True = Named "true" - fromBool False = Named "false" - asBool x - | x == fromBool True = Just True - | x == fromBool False = Just False - | True = Nothing - -instance Constants FOLEQ where - fromBool x = R (fromBool x) [] - asBool (R p _) - | fromBool True == p = Just True - | fromBool False == p = Just False - | True = Nothing - asBool _ = Nothing - -instance Predicate PredName - -instance Pretty PredName where - pretty (:=:) = text "=" - pretty (Named s) = text s - --- | Using PredName for the predicate type is not quite appropriate --- here, but we need to implement this instance so we can use it as a --- superclass of AtomEq below. -instance Apply FOLEQ PredName TermType where - foldApply f _ (EQUALS t1 t2) = f (:=:) [t1, t2] - foldApply f tf (R p ts) = maybe (f (Named p) ts) tf (asBool (Named p)) - apply' (Named p) ts = R p ts - apply' (:=:) [t1, t2] = EQUALS t1 t2 - apply' (:=:) _ = error "arity" - -{- -instance FirstOrderFormula (Formula FOLEQ) FOLEQ String where - exists = Exists - for_all = Forall - foldFirstOrder qu co tf at fm = - case fm of - F -> tf False - T -> tf True - Atom a -> at a - Not fm' -> co ((:~:) fm') - And fm1 fm2 -> co (BinOp fm1 (:&:) fm2) - Or fm1 fm2 -> co (BinOp fm1 (:|:) fm2) - Imp fm1 fm2 -> co (BinOp fm1 (:=>:) fm2) - Iff fm1 fm2 -> co (BinOp fm1 (:<=>:) fm2) - Forall v fm' -> qu C.Forall v fm' - Exists v fm' -> qu C.Exists v fm' - atomic = Atom --} - -instance C.Formula (Formula FOLEQ) FOLEQ => P.PropositionalFormula (Formula FOLEQ) FOLEQ where - foldPropositional co tf at fm = - case fm of - F -> tf False - T -> tf True - Atom a -> at a - Not fm' -> co ((:~:) fm') - And fm1 fm2 -> co (BinOp fm1 (:&:) fm2) - Or fm1 fm2 -> co (BinOp fm1 (:|:) fm2) - Imp fm1 fm2 -> co (BinOp fm1 (:=>:) fm2) - Iff fm1 fm2 -> co (BinOp fm1 (:<=>:) fm2) - Forall _ _ -> error "quantifier in propositional formula" - Exists _ _ -> error "quantifier in propositional formula" - -instance Pretty FOLEQ where - pretty (EQUALS a b) = cat [pretty a, pretty (:=:), pretty b] - pretty (R s ts) = cat ([pretty s, pretty "("] ++ intersperse (text ", ") (map pretty ts) ++ [text ")"]) - -instance HasFixity (Formula FOLEQ) where - fixity = fixityFirstOrder - -instance C.Formula (Formula FOLEQ) FOLEQ => Literal (Formula FOLEQ) FOLEQ where - foldLiteral neg tf at lit = - case lit of - F -> tf False - T -> tf True - Atom a -> at a - Not fm' -> neg fm' - _ -> error "Literal (Formula FOLEQ)" - --- instance PredicateEq PredName where --- eqp = (:=:) - -instance AtomEq FOLEQ PredName TermType where - foldAtomEq pr tf _ (R p ts) = maybe (pr (Named p) ts) tf (asBool (Named p)) - foldAtomEq _ _ eq (EQUALS t1 t2) = eq t1 t2 - equals = EQUALS - applyEq' (Named s) ts = R s ts - applyEq' (:=:) [t1, t2] = EQUALS t1 t2 - applyEq' _ _ = error "arity" - -instance C.Atom FOLEQ TermType String where - substitute = substAtomEq - freeVariables = varAtomEq - allVariables = varAtomEq - unify = unifyAtomsEq - match = matchAtomsEq - foldTerms f r (R _ ts) = foldr f r ts - foldTerms f r (EQUALS t1 t2) = f t2 (f t1 r) - isRename = isRenameOfAtomEq - getSubst = getSubstAtomEq diff --git a/Data/Logic/Types/Harrison/FOL.hs b/Data/Logic/Types/Harrison/FOL.hs deleted file mode 100644 --- a/Data/Logic/Types/Harrison/FOL.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, - TypeFamilies, TypeSynonymInstances #-} -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -module Data.Logic.Types.Harrison.FOL - ( TermType(..) - , FOL(..) - , Function(..) - ) where - -import Data.Generics (Data, Typeable) -import Data.List (intersperse) -import Data.Logic.Classes.Arity -import Data.Logic.Classes.Apply (Apply(..), Predicate) ---import Data.Logic.Classes.Combine (Combination(..), BinOp(..)) -import Data.Logic.Classes.Constants (Constants(fromBool), asBool) ---import Data.Logic.Classes.FirstOrder (foldAtomsFirstOrder, mapAtomsFirstOrder) ---import qualified Data.Logic.Classes.Formula as C -import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), Fixity(..), FixityDirection(..)) -import Data.Logic.Classes.Skolem (Skolem(..)) -import Data.Logic.Classes.Term (Term(vt, foldTerm, fApp)) -import qualified Data.Logic.Classes.Term as C ---import qualified Data.Logic.Classes.FirstOrder as C ---import Data.Logic.Types.Harrison.Formulas.FirstOrder (Formula(..)) -import qualified Data.Logic.Types.Common ({- instance Variable String -}) -import Prelude hiding (pred) -import Text.PrettyPrint (text, cat) - --- ------------------------------------------------------------------------- --- Terms. --- ------------------------------------------------------------------------- - -data TermType - = Var String - | Fn Function [TermType] - deriving (Eq, Ord) - -data FOL = R String [TermType] deriving (Eq, Ord, Show) - -instance Show TermType where - show (Var v) = "vt " ++ show v - show (Fn f ts) = "fApp " ++ show f ++ " " ++ show ts - -instance Pretty TermType where - pretty (Var v) = pretty v - pretty (Fn f ts) = cat ([pretty f, text "("] ++ intersperse (text ", ") (map pretty ts) ++ [text ")"]) - -instance Apply FOL String TermType where - foldApply f tf (R p ts) = maybe (f p ts) tf (asBool p) - apply' = R - --- | This is probably dangerous. -instance Constants String where - fromBool True = "true" - fromBool False = "false" - asBool x - | x == fromBool True = Just True - | x == fromBool False = Just False - | True = Nothing - -instance Constants FOL where - fromBool x = R (fromBool x) [] - asBool (R p _) = asBool p - -instance Predicate String - -{- -instance Pretty String where - pretty = text - -instance FirstOrderFormula (Formula FOL) FOL String where - -- type C.Term (Formula FOL) = Term - -- type V (Formula FOL) = String - -- type Pr (Formula FOL) = String - -- type Fn (Formula FOL) = String -- ^ Atomic function type - - -- quant C.Exists v fm = H.Exists v fm - -- quant C.Forall v fm = H.Forall v fm - for_all = H.Forall - exists = H.Exists - atomic = Atom - foldFirstOrder qu co tf at fm = - case fm of - F -> tf False - T -> tf True - Atom atom -> at atom - Not fm' -> co ((:~:) fm') - And fm1 fm2 -> co (BinOp fm1 (:&:) fm2) - Or fm1 fm2 -> co (BinOp fm1 (:|:) fm2) - Imp fm1 fm2 -> co (BinOp fm1 (:=>:) fm2) - Iff fm1 fm2 -> co (BinOp fm1 (:<=>:) fm2) - H.Forall v fm' -> qu C.Forall v fm' - H.Exists v fm' -> qu C.Exists v fm' --} - -instance Pretty FOL where - pretty (R p ts) = cat ([pretty p, text "("] ++ intersperse (text ", ") (map pretty ts) ++ [text ")"]) - -instance Arity String where - arity _ = Nothing - --- | The Harrison book uses String for atomic function, but we need --- something a little more type safe because of our Skolem class. -data Function - = FName String - | Skolem String - deriving (Eq, Ord, Data, Typeable, Show) - -instance Pretty Function where - pretty (FName s) = text s - pretty (Skolem v) = text ("sK" ++ v) - -instance C.Function Function String - -instance Skolem Function String where - toSkolem = Skolem - isSkolem (Skolem _) = True - isSkolem _ = False - -instance Term TermType String Function where - -- type V Term = String - -- type Fn Term = String - vt = Var - fApp = Fn - foldTerm vfn _ (Var x) = vfn x - foldTerm _ ffn (Fn f ts) = ffn f ts - zipTerms = undefined - -instance HasFixity FOL where - fixity = const (Fixity 10 InfixN) diff --git a/Data/Logic/Types/Harrison/Formulas/FirstOrder.hs b/Data/Logic/Types/Harrison/Formulas/FirstOrder.hs deleted file mode 100644 --- a/Data/Logic/Types/Harrison/Formulas/FirstOrder.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, DeriveDataTypeable, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, - TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Wwarn #-} -module Data.Logic.Types.Harrison.Formulas.FirstOrder - ( Formula(..) - ) where - ---import Data.Char (isDigit) -import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..)) -import Data.Logic.Classes.Constants (Constants(..)) -import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), prettyFirstOrder, foldAtomsFirstOrder, mapAtomsFirstOrder) -import qualified Data.Logic.Classes.FirstOrder as C -import qualified Data.Logic.Classes.Formula as C -import Data.Logic.Classes.Negate (Negatable(..)) -import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity) -import Data.Logic.Types.Common ({- instance Variable String -}) - -data Formula a - = F - | T - | Atom a - | Not (Formula a) - | And (Formula a) (Formula a) - | Or (Formula a) (Formula a) - | Imp (Formula a) (Formula a) - | Iff (Formula a) (Formula a) - | Forall String (Formula a) - | Exists String (Formula a) - deriving (Eq, Ord) - -instance Negatable (Formula atom) where - negatePrivate T = F - negatePrivate F = T - negatePrivate x = Not x - foldNegation normal inverted (Not x) = foldNegation inverted normal x - foldNegation normal _ x = normal x - -instance Constants (Formula a) where - fromBool True = T - fromBool False = F - asBool T = Just True - asBool F = Just False - asBool _ = Nothing - -instance Combinable (Formula a) where - a .<=>. b = Iff a b - a .=>. b = Imp a b - a .|. b = Or a b - a .&. b = And a b - -instance (Constants a, Pretty a, HasFixity a) => C.Formula (Formula a) a where - atomic = Atom - foldAtoms = foldAtomsFirstOrder - mapAtoms = mapAtomsFirstOrder - -instance (C.Formula (Formula a) a, Constants a, Pretty a, HasFixity a) => FirstOrderFormula (Formula a) a String where - for_all = Forall - exists = Exists - foldFirstOrder qu co tf at fm = - case fm of - F -> tf False - T -> tf True - Atom atom -> at atom - Not fm' -> co ((:~:) fm') - And fm1 fm2 -> co (BinOp fm1 (:&:) fm2) - Or fm1 fm2 -> co (BinOp fm1 (:|:) fm2) - Imp fm1 fm2 -> co (BinOp fm1 (:=>:) fm2) - Iff fm1 fm2 -> co (BinOp fm1 (:<=>:) fm2) - Forall v fm' -> qu C.Forall v fm' - Exists v fm' -> qu C.Exists v fm' - -instance (FirstOrderFormula (Formula a) a String) => Pretty (Formula a) where - pretty = prettyFirstOrder (const pretty) pretty 0 diff --git a/Data/Logic/Types/Harrison/Formulas/Propositional.hs b/Data/Logic/Types/Harrison/Formulas/Propositional.hs deleted file mode 100644 --- a/Data/Logic/Types/Harrison/Formulas/Propositional.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, DeriveDataTypeable, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Wwarn #-} -module Data.Logic.Types.Harrison.Formulas.Propositional - ( Formula(..) - ) where - -import Data.Logic.Classes.Constants (Constants(..)) -import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..)) -import qualified Data.Logic.Classes.Formula as C -import Data.Logic.Classes.Literal (Literal(..)) -import Data.Logic.Classes.Negate (Negatable(..)) -import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), topFixity) -import Data.Logic.Classes.Propositional (PropositionalFormula(..), prettyPropositional, fixityPropositional, foldAtomsPropositional, mapAtomsPropositional) - -data Formula a - = F - | T - | Atom a - | Not (Formula a) - | And (Formula a) (Formula a) - | Or (Formula a) (Formula a) - | Imp (Formula a) (Formula a) - | Iff (Formula a) (Formula a) - deriving (Eq, Ord) - -instance Negatable (Formula atom) where - negatePrivate T = F - negatePrivate F = T - negatePrivate x = Not x - foldNegation normal inverted (Not x) = foldNegation inverted normal x - foldNegation normal _ x = normal x - -instance Constants (Formula a) where - fromBool True = T - fromBool False = F - asBool T = Just True - asBool F = Just False - asBool _ = Nothing - -instance Combinable (Formula a) where - a .<=>. b = Iff a b - a .=>. b = Imp a b - a .|. b = Or a b - a .&. b = And a b - -instance (Pretty atom, HasFixity atom, Ord atom) => C.Formula (Formula atom) atom where - atomic = Atom - foldAtoms = foldAtomsPropositional - mapAtoms = mapAtomsPropositional - -instance (Combinable (Formula atom), Pretty atom, HasFixity atom, Ord atom) => PropositionalFormula (Formula atom) atom where - -- The atom type for this formula is the same as its first type parameter. - foldPropositional co tf at formula = - case formula of - T -> tf True - F -> tf False - Not f -> co ((:~:) f) - And f g -> co (BinOp f (:&:) g) - Or f g -> co (BinOp f (:|:) g) - Imp f g -> co (BinOp f (:=>:) g) - Iff f g -> co (BinOp f (:<=>:) g) - Atom x -> at x - -instance (HasFixity atom, Pretty atom, Ord atom) => Literal (Formula atom) atom where - foldLiteral neg tf at formula = - case formula of - T -> tf True - F -> tf False - Not f -> neg f - Atom x -> at x - _ -> error ("Unexpected literal " ++ show (pretty formula)) - -instance (Pretty atom, HasFixity atom, Ord atom) => Pretty (Formula atom) where - pretty = prettyPropositional pretty topFixity - -instance (Pretty atom, HasFixity atom, Ord atom) => HasFixity (Formula atom) where - fixity = fixityPropositional diff --git a/Data/Logic/Types/Harrison/Prop.hs b/Data/Logic/Types/Harrison/Prop.hs deleted file mode 100644 --- a/Data/Logic/Types/Harrison/Prop.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, - ScopedTypeVariables, TypeFamilies, TypeSynonymInstances #-} -{-# OPTIONS_GHC -Wall -Wwarn #-} -module Data.Logic.Types.Harrison.Prop - ( Prop(..) - ) where - -import Data.Generics (Data, Typeable) -import Data.Logic.Classes.Pretty -import Data.Logic.Classes.Propositional (showPropositional) -import Data.Logic.Types.Harrison.Formulas.Propositional (Formula(..)) -import Prelude hiding (negate) -import Text.PrettyPrint (text) - --- ========================================================================= --- Basic stuff for propositional logic: datatype, parsing and printing. --- ========================================================================= - -newtype Prop = P {pname :: String} deriving (Read, Data, Typeable, Eq, Ord) - -instance Show Prop where - show x = "P " ++ show (pname x) - -instance Pretty Prop where - pretty = text . pname - -instance HasFixity String where - fixity = const botFixity - -instance HasFixity Prop where - fixity = const botFixity - -instance Show (Formula Prop) where - show = showPropositional show - -instance Show (Formula String) where - show = showPropositional show diff --git a/Data/Logic/Types/Propositional.hs b/Data/Logic/Types/Propositional.hs deleted file mode 100644 --- a/Data/Logic/Types/Propositional.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} -module Data.Logic.Types.Propositional where - -import Data.Generics (Data, Typeable) -import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..)) -import Data.Logic.Classes.Constants (Constants(..), asBool) -import qualified Data.Logic.Classes.Formula as C -import Data.Logic.Classes.Literal (Literal(..)) -import Data.Logic.Classes.Negate (Negatable(..)) -import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), topFixity) -import Data.Logic.Classes.Propositional (PropositionalFormula(..), prettyPropositional, fixityPropositional, foldAtomsPropositional, mapAtomsPropositional) - --- | The range of a formula is {True, False} when it has no free variables. -data Formula atom - = Combine (Combination (Formula atom)) - | Atom atom - | T - | F - -- Note that a derived Eq instance is not going to tell us that - -- a&b is equal to b&a, let alone that ~(a&b) equals (~a)|(~b). - deriving (Eq,Ord,Data,Typeable) - -instance Negatable (Formula atom) where - negatePrivate x = Combine ((:~:) x) - foldNegation normal inverted (Combine ((:~:) x)) = foldNegation inverted normal x - foldNegation normal _ x = normal x - -instance (Ord atom) => Combinable (Formula atom) where - x .<=>. y = Combine (BinOp x (:<=>:) y) - x .=>. y = Combine (BinOp x (:=>:) y) - x .|. y = Combine (BinOp x (:|:) y) - x .&. y = Combine (BinOp x (:&:) y) - - -instance Constants (Formula atom) where - fromBool True = T - fromBool False = F - asBool T = Just True - asBool F = Just False - asBool _ = Nothing - -instance (Pretty atom, HasFixity atom, Ord atom) => C.Formula (Formula atom) atom where - atomic = Atom - foldAtoms = foldAtomsPropositional - mapAtoms = mapAtomsPropositional - -instance (Pretty atom, HasFixity atom, Ord atom) => Literal (Formula atom) atom where - foldLiteral neg tf at formula = - case formula of - Combine ((:~:) p) -> neg p - Combine _ -> error ("Unexpected literal: " ++ show (pretty formula)) - Atom x -> at x - T -> tf True - F -> tf False - -instance (C.Formula (Formula atom) atom, Pretty atom, HasFixity atom, Ord atom) => PropositionalFormula (Formula atom) atom where - foldPropositional co tf at formula = - case formula of - Combine x -> co x - Atom x -> at x - T -> tf True - F -> tf False - -instance (Pretty atom, HasFixity atom, Ord atom) => Pretty (Formula atom) where - pretty = prettyPropositional pretty topFixity - -instance (Pretty atom, HasFixity atom, Ord atom) => HasFixity (Formula atom) where - fixity = fixityPropositional diff --git a/Tests/Main.hs b/Tests/Main.hs new file mode 100644 --- /dev/null +++ b/Tests/Main.hs @@ -0,0 +1,21 @@ +import Common (TestProof) +import Data.Logic.Instances.Test (V, Formula, SkAtom, SkTerm) +import System.Exit +import Test.HUnit +import qualified Logic +import qualified Chiou0 as Chiou0 +--import qualified Data.Logic.Tests.TPTP as TPTP +import qualified Data + +main :: IO () +main = + runTestTT (TestList [Logic.tests, + Chiou0.tests, + -- TPTP.tests, -- This has a problem in the rendering code - it loops + Data.tests formulas proofs]) >>= + doCounts + where + doCounts counts' = exitWith (if errors counts' /= 0 || failures counts' /= 0 then ExitFailure 1 else ExitSuccess) + -- Generate the test data with a particular instantiation of FirstOrderFormula. + formulas = Data.allFormulas + proofs = (Data.proofs :: [TestProof Formula SkAtom SkTerm V]) diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,8 +1,20 @@ haskell-logic-classes (1.5.3) unstable; urgency=low - * Restore tests. + * Make the Show instances output more general expressions + * Drop support for pretty < 1.1.2 + * Update the Skolem class documentation + * start fixing Data.Logic.Instances.TPTP + * Move TFormula test instance from Tests/Common.hs to Data.Logic.Instances.Test + * Make the unit test code more understandable + * Replace the isSkolem method of class Skolem with fromSkolem - -- David Fox Sat, 17 Oct 2015 07:07:30 -0700 + -- David Fox Wed, 02 Sep 2015 12:29:57 -0700 + +haskell-logic-classes (1.5.1) unstable; urgency=low + + * Update Homepage and Bug-Reports fields in cabal file + + -- David Fox Mon, 13 Apr 2015 14:16:10 -0700 haskell-logic-classes (1.5) unstable; urgency=low diff --git a/logic-classes.cabal b/logic-classes.cabal --- a/logic-classes.cabal +++ b/logic-classes.cabal @@ -1,5 +1,5 @@ Name: logic-classes -Version: 1.5.3 +Version: 1.7 Synopsis: Framework for propositional and first order logic, theorem proving Description: Package to support Propositional and First Order Logic. It includes classes representing the different types of formulas and terms, some instances of @@ -17,68 +17,52 @@ Build-Type: Simple Extra-Source-Files: changelog +flag local-atp-haskell + Manual: True + Default: True + Library - GHC-options: -Wall -O2 - Exposed-Modules: Data.Logic.Classes.Apply - Data.Logic.Classes.Arity - Data.Logic.Classes.Atom - Data.Logic.Classes.ClauseNormalForm - Data.Logic.Classes.Combine - Data.Logic.Classes.Constants - Data.Logic.Classes.Equals - Data.Logic.Classes.FirstOrder - Data.Logic.Classes.Formula - Data.Logic.Classes.Literal - Data.Logic.Classes.Negate - Data.Logic.Classes.Pretty - Data.Logic.Classes.Propositional - Data.Logic.Classes.Skolem - Data.Logic.Classes.Term - Data.Logic.Classes.Variable - Data.Logic.Failing - Data.Logic.Harrison.DefCNF - Data.Logic.Harrison.DP - Data.Logic.Harrison.Equal - Data.Logic.Harrison.FOL - Data.Logic.Harrison.Formulas.FirstOrder - Data.Logic.Harrison.Formulas.Propositional - Data.Logic.Harrison.Herbrand - Data.Logic.Harrison.Lib - Data.Logic.Harrison.Meson - Data.Logic.Harrison.Normal - Data.Logic.Harrison.Prolog - Data.Logic.Harrison.Prop - Data.Logic.Harrison.PropExamples - Data.Logic.Harrison.Resolution - Data.Logic.Harrison.Skolem - Data.Logic.Harrison.Tableaux - Data.Logic.Harrison.Unif - Data.Logic.HUnit - Data.Logic.Instances.Chiou - Data.Logic.Instances.PropLogic - Data.Logic.Instances.SatSolver - -- Data.Logic.Instances.TPTP - Data.Logic.KnowledgeBase - Data.Logic.Normal.Clause - Data.Logic.Normal.Implicative - Data.Logic.Resolution - Data.Logic.Satisfiable - Data.Logic.Types.Common - Data.Logic.Types.FirstOrder - Data.Logic.Types.FirstOrderPublic - Data.Logic.Types.Harrison.Equal - Data.Logic.Types.Harrison.FOL - Data.Logic.Types.Harrison.Formulas.FirstOrder - Data.Logic.Types.Harrison.Formulas.Propositional - Data.Logic.Types.Harrison.Prop - Data.Logic.Types.Propositional - Data.Boolean - Data.Boolean.SatSolver - Build-Depends: applicative-extras, base >= 4.3 && < 5, containers, HUnit, mtl, pretty, PropLogic, safecopy, set-extra, syb, template-haskell + GHC-options: -Wall -O2 + Exposed-Modules: + Data.Logic + Data.Logic.Classes.Atom + Data.Logic.Classes.ClauseNormalForm + Data.Logic.Harrison.Formulas.FirstOrder + Data.Logic.Harrison.Formulas.Propositional + Data.Logic.Instances.Chiou + Data.Logic.Instances.PropLogic + Data.Logic.Instances.SatSolver + Data.Logic.Instances.Test + -- Data.Logic.Instances.TPTP + Data.Logic.KnowledgeBase + Data.Logic.Normal.Clause + Data.Logic.Normal.Implicative + Data.Logic.Resolution + Data.Logic.Satisfiable + Data.Logic.Types.FirstOrder + Data.Logic.Types.FirstOrderPublic + Data.Boolean + Data.Boolean.SatSolver + Build-Depends: + applicative-extras, + atp-haskell, + base >= 4.3 && < 5, + containers, + HUnit, + -- logic-TPTP, + mtl, + parsec, + pretty >= 1.1.2, + PropLogic, + safe, + safecopy, + set-extra, + syb, + template-haskell Test-Suite logic-classes-tests - Type: exitcode-stdio-1.0 - GHC-Options: -Wall -O2 - Hs-Source-Dirs: Data/Logic/Tests - Main-Is: Main.hs - Build-Depends: applicative-extras, base, containers, HUnit, logic-classes, mtl, pretty, PropLogic, set-extra, syb + Type: exitcode-stdio-1.0 + GHC-Options: -Wall -O2 -fno-warn-orphans + Hs-Source-Dirs: Tests + Main-Is: Main.hs + Build-Depends: applicative-extras, atp-haskell, base, containers, HUnit, logic-classes, mtl, pretty >= 1.1.2, PropLogic, safe, set-extra, syb