packages feed

logic-classes 1.5.3 → 1.7

raw patch · 59 files changed

+1177/−9175 lines, 59 filesdep +atp-haskelldep +parsecdep +safedep ~pretty

Dependencies added: atp-haskell, parsec, safe

Dependency ranges changed: pretty

Files

Data/Boolean.hs view
@@ -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
Data/Boolean/SatSolver.hs view
@@ -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. <http://en.wikipedia.org/wiki/DPLL_algorithm>) 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
+ Data/Logic.hs view
@@ -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)
− Data/Logic/Classes/Apply.hs 
@@ -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)
− Data/Logic/Classes/Arity.hs 
@@ -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
Data/Logic/Classes/ClauseNormalForm.hs view
@@ -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
− Data/Logic/Classes/Combine.hs 
@@ -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
− Data/Logic/Classes/Constants.hs 
@@ -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
− Data/Logic/Classes/Equals.hs 
@@ -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))
− Data/Logic/Classes/FirstOrder.hs 
@@ -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)
− Data/Logic/Classes/Formula.hs 
@@ -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
− Data/Logic/Classes/Literal.hs 
@@ -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
− Data/Logic/Classes/Negate.hs 
@@ -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
− Data/Logic/Classes/Pretty.hs 
@@ -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
− Data/Logic/Classes/Propositional.hs 
@@ -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)
− Data/Logic/Classes/Skolem.hs 
@@ -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
− Data/Logic/Classes/Term.hs 
@@ -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
− Data/Logic/Classes/Variable.hs 
@@ -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)) ++ ")"
− Data/Logic/Failing.hs 
@@ -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)
− Data/Logic/HUnit.hs 
@@ -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--}
− Data/Logic/Harrison/DP.hs 
@@ -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))))]
− Data/Logic/Harrison/DefCNF.hs 
@@ -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 <<p <=> (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))
− Data/Logic/Harrison/Equal.hs 
@@ -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- <<forall c. f(f(f(f(f(c))))) = c /\ f(f(f(c))) = c ==> f(c) = c>>;;--time meson fm;;--let fm =- <<axiom(f(f(f(f(f(c))))),c) /\-   axiom(c,f(f(f(f(f(c)))))) /\-   axiom(f(f(f(c))),c) /\-   axiom(c,f(f(f(c)))) /\-   (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 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;;--}
− Data/Logic/Harrison/FOL.hs 
@@ -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 y. exists z. x < z /\ y < z>>;;--<<~(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--}-
Data/Logic/Harrison/Formulas/FirstOrder.hs view
@@ -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
Data/Logic/Harrison/Formulas/Propositional.hs view
@@ -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"
− Data/Logic/Harrison/Herbrand.hs 
@@ -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 <<exists x. forall y. P(x) ==> P(y)>>;;--let sfm = skolemize(Not <<exists x. forall y. P(x) ==> 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;;--}
− Data/Logic/Harrison/Lib.hs 
@@ -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 "<func>";;--#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;;--}
− Data/Logic/Harrison/Meson.hs 
@@ -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 <<forall a. ~(P(a) /\ (forall y z. Q(y) \/ R(z)) /\ ~P(a))>>;;--tab <<forall a. ~(P(a) /\ ~P(a) /\ (forall y z. Q(y) \/ R(z)))>>;;---- ------------------------------------------------------------------------- --- 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- <<p ==> 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- <<p \/ ~p>>;;--let prop_7 = time meson- <<p \/ ~ ~ ~p>>;;--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 <=> p>>;;--let prop_12 = time meson- <<((p <=> q) <=> r) <=> (p <=> (q <=> r))>>;;--let prop_13 = time meson- <<p \/ q /\ r <=> (p \/ q) /\ (p \/ r)>>;;--let prop_14 = time meson- <<(p <=> q) <=> (q \/ ~p) /\ (~q \/ p)>>;;--let prop_15 = time meson- <<p ==> q <=> ~p \/ q>>;;--let prop_16 = time meson- <<(p ==> q) \/ (q ==> p)>>;;--let prop_17 = time meson- <<p /\ (q ==> r) ==> s <=> (~p \/ q \/ s) /\ (~p \/ ~r \/ s)>>;;---- ------------------------------------------------------------------------- --- Monadic Predicate Logic.                                                  --- ------------------------------------------------------------------------- --let p18 = time meson- <<exists y. forall x. P(y) ==> P(x)>>;;--let p19 = time meson- <<exists x. forall y z. (P(y) ==> 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- <<exists x y. P(x,y) ==> (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- <<lives(agatha) /\ lives(butler) /\ lives(charles) /\-   (killed(agatha,agatha) \/ killed(butler,agatha) \/-    killed(charles,agatha)) /\-   (forall x y. killed(x,y) ==> 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(f((a),b),f(b,c)) /\-  P(f(b,c),f(a,c)) /\-  (forall (x) y z. P(x,y) /\ P(y,z) ==> P(x,z))-  ==> P(f(a,b),f(a,c))>>;;---- ------------------------------------------------------------------------- --- See info-hol, circa 1500.                                                 --- ------------------------------------------------------------------------- --let p58 = time meson- <<forall P Q R. forall x. exists v. exists w. forall y. forall z.-    ((P(x) /\ Q(y)) ==> ((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- <<forall x. P(x,f(x)) <=>-            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- <<exists x. forall y z.-      ((F(y) ==> 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- <<exists x y. forall z.-        (F(x,z) <=> 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- <<exists x. forall y z.-        ((F(y,z) ==> (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- <<exists x y. forall z.-        (F(x,y) ==> 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- <<forall x. exists y.-        (exists u. forall v. F(u,x) ==> 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- <<exists x. forall y z.-        ((F(y,z) ==> (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 x. exists y. forall z.-        ((forall u. exists v. F(y,u,v) /\ G(y,u) /\ ~H(y,x))-          ==> (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- <<exists x. exists y. forall z.-        (F(x,y) ==> (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;;--}
− Data/Logic/Harrison/Normal.hs 
@@ -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)))
− Data/Logic/Harrison/Prolog.hs 
@@ -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;;                           --}
− Data/Logic/Harrison/Prop.hs 
@@ -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 <<p /\ q ==> q /\ r>>-     (function P"p" -> true | P"q" -> false | P"r" -> true);;--eval <<p /\ q ==> 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))
− Data/Logic/Harrison/PropExamples.hs 
@@ -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)))]
− Data/Logic/Harrison/Resolution.hs 
@@ -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- <<p ==> 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- <<p \/ ~p>>;;--let p7 = time presolution- <<p \/ ~ ~ ~p>>;;--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 <=> p>>;;--let p12 = time presolution- <<((p <=> q) <=> r) <=> (p <=> (q <=> r))>>;;--let p13 = time presolution- <<p \/ q /\ r <=> (p \/ q) /\ (p \/ r)>>;;--let p14 = time presolution- <<(p <=> q) <=> (q \/ ~p) /\ (~q \/ p)>>;;--let p15 = time presolution- <<p ==> q <=> ~p \/ q>>;;--let p16 = time presolution- <<(p ==> q) \/ (q ==> p)>>;;--let p17 = time presolution- <<p /\ (q ==> r) ==> s <=> (~p \/ q \/ s) /\ (~p \/ ~r \/ s)>>;;---- ------------------------------------------------------------------------- --- Monadic Predicate Logic.                                                  --- ------------------------------------------------------------------------- --let p18 = time presolution- <<exists y. forall x. P(y) ==> P(x)>>;;--let p19 = time presolution- <<exists x. forall y z. (P(y) ==> 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- <<exists x y. P(x,y) ==> (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- <<lives(agatha) /\ lives(butler) /\ lives(charles) /\-   (killed(agatha,agatha) \/ killed(butler,agatha) \/-    killed(charles,agatha)) /\-   (forall x y. killed(x,y) ==> 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(f((a),b),f(b,c)) /\-   P(f(b,c),f(a,c)) /\-   (forall (x) y z. P(x,y) /\ P(y,z) ==> P(x,z))-   ==> P(f(a,b),f(a,c))>>;;---- ------------------------------------------------------------------------- --- See info-hol, circa 1500.                                                 --- ------------------------------------------------------------------------- --let p58 = time presolution- <<forall P Q R. forall x. exists v. exists w. forall y. forall z.-    ((P(x) /\ Q(y)) ==> ((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- <<forall x. P(x,f(x)) <=>-            exists y. (forall z. P(z,y) ==> P(z,f(x))) /\ P(x,y)>>;;---- ------------------------------------------------------------------------- --- From Gilmore's classic paper.                                             --- ------------------------------------------------------------------------- --let gilmore_1 = time presolution- <<exists x. forall y z.-      ((F(y) ==> 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- <<exists x y. forall z.-        (F(x,z) <=> 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- <<exists x. forall y z.-        ((F(y,z) ==> (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- <<exists x y. forall z.-        (F(x,y) ==> 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- <<forall x. exists y.-        (exists u. forall v. F(u,x) ==> 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- <<exists x. forall y z.-        ((F(y,z) ==> (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 x. exists y. forall z.-        ((forall u. exists v. F(y,u,v) /\ G(y,u) /\ ~H(y,x))-          ==> (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- <<exists x. exists y. forall z.-        (F(x,y) ==> (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- <<exists x. forall y z.-      ((F(y) ==> 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- <<p ==> 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- <<p \/ ~p>>;;--let p7 = time resolution- <<p \/ ~ ~ ~p>>;;--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 <=> p>>;;--let p12 = time resolution- <<((p <=> q) <=> r) <=> (p <=> (q <=> r))>>;;--let p13 = time resolution- <<p \/ q /\ r <=> (p \/ q) /\ (p \/ r)>>;;--let p14 = time resolution- <<(p <=> q) <=> (q \/ ~p) /\ (~q \/ p)>>;;--let p15 = time resolution- <<p ==> q <=> ~p \/ q>>;;--let p16 = time resolution- <<(p ==> q) \/ (q ==> p)>>;;--let p17 = time resolution- <<p /\ (q ==> r) ==> s <=> (~p \/ q \/ s) /\ (~p \/ ~r \/ s)>>;;--(* ------------------------------------------------------------------------- *)-(* Monadic Predicate Logic.                                                  *)-(* ------------------------------------------------------------------------- *)--let p18 = time resolution- <<exists y. forall x. P(y) ==> P(x)>>;;--let p19 = time resolution- <<exists x. forall y z. (P(y) ==> 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- <<exists x y. P(x,y) ==> (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- <<lives(agatha) /\ lives(butler) /\ lives(charles) /\-   (killed(agatha,agatha) \/ killed(butler,agatha) \/-    killed(charles,agatha)) /\-   (forall x y. killed(x,y) ==> 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(f((a),b),f(b,c)) /\-   P(f(b,c),f(a,c)) /\-   (forall (x) y z. P(x,y) /\ P(y,z) ==> P(x,z))-   ==> P(f(a,b),f(a,c))>>;;--(* ------------------------------------------------------------------------- *)-(* See info-hol, circa 1500.                                                 *)-(* ------------------------------------------------------------------------- *)--let p58 = time resolution- <<forall P Q R. forall x. exists v. exists w. forall y. forall z.-    ((P(x) /\ Q(y)) ==> ((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- <<forall x. P(x,f(x)) <=>-            exists y. (forall z. P(z,y) ==> P(z,f(x))) /\ P(x,y)>>;;--(* ------------------------------------------------------------------------- *)-(* From Gilmore's classic paper.                                             *)-(* ------------------------------------------------------------------------- *)--let gilmore_1 = time resolution- <<exists x. forall y z.-      ((F(y) ==> 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- <<exists x y. forall z.-        (F(x,z) <=> 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- <<exists x. forall y z.-        ((F(y,z) ==> (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- <<exists x y. forall z.-        (F(x,y) ==> 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- <<forall x. exists y.-        (exists u. forall v. F(u,x) ==> 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- <<exists x. forall y z.-        ((F(y,z) ==> (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 x. exists y. forall z.-        ((forall u. exists v. F(y,u,v) /\ G(y,u) /\ ~H(y,x))-          ==> (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- <<exists x. exists y. forall z.-        (F(x,y) ==> (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;;--}
− Data/Logic/Harrison/Skolem.hs 
@@ -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
− Data/Logic/Harrison/Tableaux.hs 
@@ -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- <<forall x. P(x,f[vt "x"]) .<=>.-             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- <<p .=>. 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- <<p .|. ~p>>;;--let p7 = time splittab- <<p .|. ~ ~ ~p>>;;--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 .<=>. p>>;;--let p12 = time splittab- <<((p .<=>. q) .<=>. r) .<=>. (p .<=>. (q .<=>. r))>>;;--let p13 = time splittab- <<p .|. q .&. r .<=>. (p .|. q) .&. (p .|. r)>>;;--let p14 = time splittab- <<(p .<=>. q) .<=>. (q .|. ~p) .&. (~q .|. p)>>;;--let p15 = time splittab- <<p .=>. q .<=>. ~p .|. q>>;;--let p16 = time splittab- <<(p .=>. q) .|. (q .=>. p)>>;;--let p17 = time splittab- <<p .&. (q .=>. r) .=>. s .<=>. (~p .|. q .|. s) .&. (~p .|. ~r .|. s)>>;;---- ------------------------------------------------------------------------- --- Pelletier problems: monadic predicate logic.                              --- ------------------------------------------------------------------------- --let p18 = time splittab- <<exists y. forall x. P[vt "y"] .=>. P[vt "x"]>>;;--let p19 = time splittab- <<exists x. forall y z. (P[vt "y"] .=>. 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- <<exists x y. P(x,y) .=>. (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- <<lives(agatha) .&. lives(butler) .&. lives(charles) .&.-   (killed(agatha,agatha) .|. killed(butler,agatha) .|.-    killed(charles,agatha)) .&.-   (forall x y. killed(x,y) .=>. 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(f([vt "a"],b),f(b,c)) .&.-   P(f(b,c),f(a,c)) .&.-   (forall [vt "x"] y z. P(x,y) .&. P(y,z) .=>. P(x,z))-   .=>. P(f(a,b),f(a,c))>>;;---- ------------------------------------------------------------------------- --- See info-hol, circa 1500.                                                 --- ------------------------------------------------------------------------- --let p58 = time splittab- <<forall P Q R. forall x. exists v. exists w. forall y. forall z.-    ((P[vt "x"] .&. Q[vt "y"]) .=>. ((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- <<forall x. P(x,f[vt "x"]) .<=>.-            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- <<exists x. forall y z.-      ((F[vt "y"] .=>. 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- <<exists x y. forall z.-        (F(x,z) .<=>. 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- <<exists x. forall y z.-        ((F(y,z) .=>. (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- <<exists x y. forall z.-        (F(x,y) .=>. 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- <<forall x. exists y.-        (exists u. forall v. F(u,x) .=>. 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- <<exists x. forall y z.-        ((F(y,z) .=>. (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 x. exists y. forall z.-        ((forall u. exists v. F(y,u,v) .&. G(y,u) .&. ~H(y,x))-          .=>. (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- <<exists x. exists y. forall z.-        (F(x,y) .=>. (F(y,z) .&. F(z,z))) .&.-        ((F(x,y) .&. G(x,y)) .=>. (G(x,z) .&. G(z,z)))>>;;--************ -}---}
− Data/Logic/Harrison/Unif.hs 
@@ -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;;--}
Data/Logic/Instances/Chiou.hs view
@@ -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
Data/Logic/Instances/PropLogic.hs view
@@ -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
Data/Logic/Instances/SatSolver.hs view
@@ -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
+ Data/Logic/Instances/Test.hs view
@@ -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)
Data/Logic/KnowledgeBase.hs view
@@ -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'})
Data/Logic/Normal/Clause.hs view
@@ -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
Data/Logic/Normal/Implicative.hs view
@@ -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)
Data/Logic/Resolution.hs view
@@ -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
Data/Logic/Satisfiable.hs view
@@ -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)
− Data/Logic/Tests/Main.hs 
@@ -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])
− Data/Logic/Types/Common.hs 
@@ -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)--}
Data/Logic/Types/FirstOrder.hs view
@@ -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)
Data/Logic/Types/FirstOrderPublic.hs view
@@ -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)
− Data/Logic/Types/Harrison/Equal.hs 
@@ -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
− Data/Logic/Types/Harrison/FOL.hs 
@@ -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)
− Data/Logic/Types/Harrison/Formulas/FirstOrder.hs 
@@ -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
− Data/Logic/Types/Harrison/Formulas/Propositional.hs 
@@ -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
− Data/Logic/Types/Harrison/Prop.hs 
@@ -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
− Data/Logic/Types/Propositional.hs 
@@ -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
+ Tests/Main.hs view
@@ -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])
changelog view
@@ -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 <dsf@seereason.com>  Sat, 17 Oct 2015 07:07:30 -0700+ -- David Fox <dsf@seereason.com>  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 <dsf@seereason.com>  Mon, 13 Apr 2015 14:16:10 -0700  haskell-logic-classes (1.5) unstable; urgency=low
logic-classes.cabal view
@@ -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