packages feed

logic-classes 0.48 → 1.1

raw patch · 72 files changed

+10028/−3310 lines, 72 filesdep +applicative-extrassetup-changed

Dependencies added: applicative-extras

Files

− Data/Logic.hs 
@@ -1,47 +0,0 @@-{-# OPTIONS -Wwarn #-}-module Data.Logic-    ( -- * Boolean Logic-      Negatable(..)-    , Boolean(fromBool)-    , Logic(..)-    -- * Propositional Logic-    , PropositionalFormula(..)-    , Combine(..)-    , BinOp(..)-    -- * FirstOrderLogic-    , Variable(..)-    , Arity(arity)-    , Pred(..)-    , pApp-    , Predicate(..)-    , Skolem(..)-    , Term(..)-    , FirstOrderFormula(..)-    -- * Normal Forms-    , Literal(..)-    , ClauseNormalFormula(..)-    , ImplicativeForm(..)-    -- * Knowledge Base and Theorem Proving-    , Proof(proofResult)-    , ProofResult(Proved, Invalid, Disproved)-    , tellKB-    , runProverT'-    , prettyProof-    ) where--import Data.Logic.Classes.Arity-import Data.Logic.Classes.Boolean-import Data.Logic.Classes.ClauseNormalForm-import Data.Logic.Classes.FirstOrder-import Data.Logic.Classes.Literal-import Data.Logic.Classes.Logic-import Data.Logic.Classes.Negatable-import Data.Logic.Classes.Pred-import Data.Logic.Classes.Propositional-import Data.Logic.Classes.Skolem-import Data.Logic.Classes.Term-import Data.Logic.Classes.Variable-import Data.Logic.KnowledgeBase-import Data.Logic.Normal.Implicative-import Data.Logic.Types.FirstOrder ()-import Data.Logic.Types.FirstOrderPublic ()
+ Data/Logic/Classes/Apply.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, 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(..)+    , apply+    , zipApplys+    , apply0, apply1, apply2, apply3, apply4, apply5, apply6, apply7+    , showApply+    , prettyApply+    , varApply+    , substApply+    ) where++import Data.Logic.Classes.Arity+import Data.Logic.Classes.Constants+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, hcat)++class (Arity p, Constants p, Eq 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 (hcat (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+-}
Data/Logic/Classes/Arity.hs view
@@ -4,7 +4,8 @@  -- |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, or that any number--- of arguments may be passed.+-- 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/Boolean.hs 
@@ -1,8 +0,0 @@-module Data.Logic.Classes.Boolean-    ( Boolean(fromBool)-    ) where---- |Some types in the Logic class heirarchy need to have True and--- False elements.-class Boolean p where-    fromBool :: Bool -> p
Data/Logic/Classes/ClauseNormalForm.hs view
@@ -4,7 +4,7 @@     ) where  import Control.Monad (MonadPlus)-import Data.Logic.Classes.Negatable+import Data.Logic.Classes.Negate import Data.Set as S  -- |A class to represent formulas in CNF, which is the conjunction of
+ Data/Logic/Classes/Combine.hs view
@@ -0,0 +1,114 @@+-- | 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+    , (==>)+    , (<=>)+    ) where++import Data.Generics (Data, Typeable)+import Data.Logic.Classes.Negate (Negatable, (.~.))++-- | 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)++infixr 2  .<=>. ,  .=>. ,  .<~>., ⇒, ⇔, ==>, <=>+-- We had been using a different precedence for & and |, I'm swapping+-- 3 and 4 here to match Harrison and Haskell (and I assume most other+-- languages.)  So a .|. b .&. c means a .|. (b .&. c).  And False &&+-- True || True is True.+infixl 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)++-- | 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)++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+(<=>) = (.<=>.)
+ Data/Logic/Classes/Constants.hs view
@@ -0,0 +1,30 @@+module Data.Logic.Classes.Constants+    ( Constants(..)+    , asBool+    , ifElse+    , (⊨)+    , (⊭)+    ) where++-- |Some types in the Logic class heirarchy need to have True and+-- False elements.+class Constants p where+    fromBool :: Bool -> p+    true :: p+    true = fromBool True+    false :: p+    false = fromBool False++asBool :: (Eq p, Constants p) => p -> Maybe Bool +asBool p | p == true = Just True+         | p == false = Just False+         | True = Nothing++ifElse :: a -> a -> Bool -> a+ifElse t _ True = t+ifElse _ f False = f++(⊨) :: Constants formula => formula+(⊨) = true+(⊭) :: Constants formula => formula+(⊭) = false
+ Data/Logic/Classes/Equals.hs view
@@ -0,0 +1,194 @@+{-# 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.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.Negate ((.~.))+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 (Arity p, Constants p, Eq p, Show p) => AtomEq atom p term | atom -> p term, 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 Ord p => PredicateName p = Named p Int | Equals deriving (Eq, Ord)++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, Show p) => p -> [a] -> t+arityError p ts = error $ "arity error for " ++ show p ++ ": expected " ++ show (arity p) ++ ", got " ++ show (length ts)++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 :: (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> formula+pApp0 p = atomic (apply0 p)+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 :: (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 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 view
@@ -3,41 +3,50 @@ module Data.Logic.Classes.FirstOrder     ( FirstOrderFormula(..)     , Quant(..)-    , Predicate(..)-    , quant-    , (!), (?)-    , quant'+    , zipFirstOrder+    , pApp+    , pApp0+    , pApp1+    , pApp2+    , pApp3+    , pApp4+    , pApp5+    , pApp6+    , pApp7     , for_all'     , exists'-    , freeVars+    , quant+    , (!)+    , (?)+    , (∀)+    , (∃)+    , quant'+    , convertFOF+    , toPropositional     , withUnivQuants+    , showFirstOrder+    , prettyFirstOrder+{-+    , freeVars     , quantVars     , allVars     , univquant_free_vars     , substitute     , substitutePairs-    , convertFOF-    , toPropositional     , disj     , conj-    , showFirstOrder-    , prettyFirstOrder+-}     ) where -import Data.Function (on) import Data.Generics (Data, Typeable)-import Data.List (intercalate, intersperse)-import Data.Logic.Classes.Arity-import Data.Logic.Classes.Boolean-import Data.Logic.Classes.Logic-import Data.Logic.Classes.Pred-import Data.Logic.Classes.Propositional-import Data.Logic.Classes.Term-import Data.Monoid (mappend)+import Data.Logic.Classes.Apply (Apply(..), apply, apply0, apply1, apply2, apply3, apply4, apply5, apply6, apply7)+import Data.Logic.Classes.Constants+import Data.Logic.Classes.Combine+import Data.Logic.Classes.Propositional (PropositionalFormula)+import Data.Logic.Classes.Variable (Variable) import Data.SafeCopy (base, deriveSafeCopy)-import qualified Data.Set as S import Happstack.Data (deriveNewData)-import Text.PrettyPrint (Doc, (<>), (<+>), text, empty, parens, hcat, nest)+import Text.PrettyPrint (Doc, (<>), (<+>), text, parens, nest)  -- |The 'FirstOrderFormula' type class.  Minimal implementation: -- @for_all, exists, foldFirstOrder, foldTerm, (.=.), pApp0-pApp7, fApp, var@.  The@@ -46,26 +55,12 @@ -- without them the univquant_free_vars function gives the error @No -- instance for (FirstOrderFormula Formula term V p f)@ because the -- function doesn't mention the Term type.-class ( Term term v f-      , Pred p term formula-      , Logic formula  -- Basic logic operations-      , Data formula   -- Allows us to use Data.Generics functions on formulas+class ( Combinable formula  -- Basic logic operations+      , Constants formula+      , Constants atom+      , Variable v       , Show v-      , Data p-      , Boolean p      -- To implement true and false below-      , Arity p        -- To decide how many arguments-      , Eq p           -- Required during resolution-      , Ord p-      , Show p-      -- , Pretty p-      , Ord f-      , Show f-      ) => FirstOrderFormula formula term v p f-                                    | formula -> term-                                    , formula -> v-                                    , formula -> p-                                    , formula -> f-                                    , term -> p where+      ) => 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)@@ -76,275 +71,182 @@     -- 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)-                   -> (Combine formula -> r)-                   -> (Predicate p term -> r)+                   -> (Combination formula -> r)+                   -> (Bool -> r)+                   -> (atom -> r)                    -> formula                    -> r-    zipFirstOrder :: (Quant -> v -> formula -> Quant -> v -> formula -> Maybe r)-                  -> (Combine formula -> Combine formula -> Maybe r)-                  -> (Predicate p term -> Predicate p term -> Maybe r)-                  -> formula -> formula -> Maybe r+    atomic :: atom -> formula --- |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-    = Equal term term-    | NotEqual term term-    | Constant Bool-    | Apply p [term]-    deriving (Eq, Ord, Show, Read, Data, Typeable)+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)++pApp :: (FirstOrderFormula formula atom v, Apply atom p term) => p -> [term] -> formula+pApp p ts = atomic (apply p ts)++-- | Versions of pApp specialized for different argument counts.+pApp0 :: (FirstOrderFormula formula atom v, Apply atom p term) => p -> formula+pApp0 p = atomic (apply0 p)+pApp1 :: (FirstOrderFormula formula atom v, Apply atom p term) => p -> term -> formula+pApp1 p a = atomic (apply1 p a)+pApp2 :: (FirstOrderFormula formula atom v, Apply atom p term) => p -> term -> term -> formula+pApp2 p a b = atomic (apply2 p a b)+pApp3 :: (FirstOrderFormula formula atom v, Apply atom p term) => p -> term -> term -> term -> formula+pApp3 p a b c = atomic (apply3 p a b c)+pApp4 :: (FirstOrderFormula formula atom v, Apply 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, 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)+pApp6 :: (FirstOrderFormula formula atom v, 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)+pApp7 :: (FirstOrderFormula formula atom v, 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)+ -- |for_all with a list of variables, for backwards compatibility.-for_all' :: FirstOrderFormula formula term v p f => [v] -> formula -> formula+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 term v p f => [v] -> formula -> formula+exists' :: FirstOrderFormula formula atom v => [v] -> formula -> formula exists' vs f = foldr for_all f vs --- | Functions to disjunct or conjunct a list.-disj :: FirstOrderFormula formula term v p f => [formula] -> formula-disj [] = false-disj [x] = x-disj (x:xs) = x .|. disj xs+-- |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 -conj :: FirstOrderFormula formula term v p f => [formula] -> formula-conj [] = true-conj [x] = x-conj (x:xs) = x .&. conj xs+infix 1 !, ?, ∀, ∃ +-- | ∀ 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 term v p f => +quant :: FirstOrderFormula formula atom v =>           Quant -> v -> formula -> formula-quant All v f = for_all v f+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 term v p f => +quant' :: FirstOrderFormula formula atom v =>           Quant -> [v] -> formula -> formula-quant' All = for_all'+quant' Forall = for_all' quant' Exists = exists' --- |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 = All | Exists deriving (Eq,Ord,Show,Read,Data,Typeable,Enum,Bounded)---- |Find the free (unquantified) variables in a formula.-freeVars :: FirstOrderFormula formula term v p f => formula -> S.Set v-freeVars f =-    foldFirstOrder-          (\_ v x -> S.delete v (freeVars x))                    -          (\ cm ->-               case cm of-                 BinOp x _ y -> (mappend `on` freeVars) x y-                 (:~:) f' -> freeVars f')-          (\ pa -> case pa of-                     Constant _ -> S.empty-                     Equal t1 t2 -> S.union (freeVarsOfTerm t1) (freeVarsOfTerm t2)-                     NotEqual t1 t2 -> S.union (freeVarsOfTerm t1) (freeVarsOfTerm t2)-                     Apply _ ts -> S.unions (fmap freeVarsOfTerm ts))-          f-    where-      freeVarsOfTerm = foldTerm S.singleton (\ _ args -> S.unions (fmap freeVarsOfTerm args))---- | 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 term v p f => ([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)-                f-      doQuant vs All v f = doFormula (v : vs) f-      doQuant vs Exists v f = fn (reverse vs) (exists v f)--{--withImplication :: FirstOrderFormula formula term v p f => r -> (formula -> formula -> r) -> formula -> r-withImplication def fn formula =-    foldFirstOrder (\ _ _ _ -> def) c (\ _ -> def) formula-    where-      c (BinOp a (:=>:) b) = fn a b-      c _ = def--}---- |Find the variables that are quantified in a formula-quantVars :: FirstOrderFormula formula term v p f => formula -> S.Set v-quantVars =-    foldFirstOrder-          (\ _ v x -> S.insert v (quantVars x))-          (\ cm ->-               case cm of-                 BinOp x _ y -> (mappend `on` quantVars) x y-                 ((:~:) f) -> quantVars f)-          (\ _ -> S.empty)---- |Find the free and quantified variables in a formula.-allVars :: FirstOrderFormula formula term v p f => formula -> S.Set v-allVars f =-    foldFirstOrder-          (\_ v x -> S.insert v (allVars x))-          (\ cm ->-               case cm of-                 BinOp x _ y -> (mappend `on` allVars) x y-                 (:~:) f' -> freeVars f')-          (\ pa -> case pa of-                     Equal t1 t2 -> S.union (allVarsOfTerm t1) (allVarsOfTerm t2)-                     NotEqual t1 t2 -> S.union (allVarsOfTerm t1) (allVarsOfTerm t2)-                     Constant _ -> S.empty-                     Apply _ ts -> S.unions (fmap allVarsOfTerm ts))-          f-    where-      allVarsOfTerm = foldTerm S.singleton (\ _ args -> S.unions (fmap allVarsOfTerm args))---- | Universally quantify all free variables in the formula (Name comes from TPTP)-univquant_free_vars :: FirstOrderFormula formula term v p f => formula -> formula-univquant_free_vars cnf' =-    if S.null free then cnf' else foldr for_all cnf' (S.toList free)-    where free = freeVars cnf'---- |Replace each free occurrence of variable old with term new.-substitute :: FirstOrderFormula formula term v p f => v -> term -> formula -> formula-substitute old new 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)))-                (\ pa -> case pa of-                           Equal t1 t2 -> (st t1) .=. (st t2)-                           NotEqual t1 t2 -> (st t1) .!=. (st t2)-                           Constant x -> pApp0 (fromBool x)-                           Apply p ts -> pApp p (map st ts))-      st t = foldTerm sv (\ func ts -> fApp func (map st ts)) t-      sv v = if v == old then new else var v--substitutePairs :: (FirstOrderFormula formula term v p f) => [(v, term)] -> formula -> formula-substitutePairs pairs formula = foldr (\ (old, new) f -> substitute old new f) formula pairs ---- |Convert any instance of a first order logic expression to any other.-convertFOF :: forall formula1 term1 v1 p1 f1 formula2 term2 v2 p2 f2.-              (FirstOrderFormula formula1 term1 v1 p1 f1,-               FirstOrderFormula formula2 term2 v2 p2 f2) =>-              (v1 -> v2) -> (p1 -> p2) -> (f1 -> f2) -> formula1 -> formula2-convertFOF convertV convertP convertF formula =-    foldFirstOrder q c p formula+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 convertV convertP convertF-      convertTerm' = convertTerm convertV convertF-      q x v f = quant x (convertV v) (convert' f)-      c (BinOp f1 op f2) = combine (BinOp (convert' f1) op (convert' f2))-      c ((:~:) f) = combine ((:~:) (convert' f))-      p (Equal t1 t2) = (convertTerm' t1) .=. (convertTerm' t2)-      p (NotEqual t1 t2) = (convertTerm' t1) .!=. (convertTerm' t2)-      p (Apply x ts) = pApp (convertP x) (map convertTerm' ts)-      p (Constant x) = pApp (fromBool x) []---- |Names for for_all and exists inspired by the conventions of the--- TPTP project.-(!) :: FirstOrderFormula formula term v p f => v -> formula -> formula-(!) = for_all-(?) :: FirstOrderFormula formula term v p f => v -> formula -> formula-(?) = exists+      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 term v p f formula2 atom.-                   (FirstOrderFormula formula1 term v p f,-                    PropositionalFormula formula2 atom) =>+toPropositional :: forall formula1 atom v formula2 atom2.+                   (FirstOrderFormula formula1 atom v,+                    PropositionalFormula formula2 atom2) =>                    (formula1 -> formula2) -> formula1 -> formula2 toPropositional convertAtom formula =-    foldFirstOrder q c p formula+    foldFirstOrder qu co tf at formula     where       convert' = toPropositional convertAtom-      q _ _ _ = error "toPropositional: invalid argument"-      c (BinOp f1 op f2) = combine (BinOp (convert' f1) op (convert' f2))-      c ((:~:) f) = combine ((:~:) (convert' f))-      p _ = convertAtom formula+      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 _ = convertAtom formula  -- | Display a formula in a format that can be read into the interpreter.-showFirstOrder :: forall formula term v p f. (FirstOrderFormula formula term v p f, Show v, Show p, Show f) => -                  formula -> String-showFirstOrder formula =-    foldFirstOrder q c a formula+showFirstOrder :: forall formula atom v. (FirstOrderFormula formula atom v) => (atom -> String) -> formula -> String+showFirstOrder sa formula =+    foldFirstOrder qu co tf at formula     where-      q All v f = "(for_all " ++ show v ++ " " ++ showFirstOrder f ++ ")"-      q Exists v f = "(exists " ++  show v ++ " " ++ showFirstOrder f ++ ")"-      c (BinOp f1 op f2) = "(" ++ parenForm f1 ++ " " ++ showCombine op ++ " " ++ parenForm f2 ++ ")"-      c ((:~:) f) = "((.~.) " ++ showFirstOrder f ++ ")"-      a :: Predicate p term -> String-      a (Equal t1 t2) =-          "(" ++ parenTerm t1 ++ " .=. " ++ parenTerm t2 ++ ")"-      a (NotEqual t1 t2) =-          "(" ++ parenTerm t1 ++ " .!=. " ++ parenTerm t2 ++ ")"-      a (Constant x) = "pApp' (Constant " ++ show x ++ ")"-      a (Apply p ts) = "(pApp" ++ show (length ts) ++ " (" ++ show p ++ ") (" ++ intercalate ") (" (map showTerm ts) ++ "))"-      parenForm x = "(" ++ showFirstOrder x ++ ")"-      parenTerm :: term -> String-      parenTerm x = "(" ++ showTerm x ++ ")"+      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 term v p f. (FirstOrderFormula formula term v p f) =>-                    (v -> Doc)-                 -> (p -> Doc)-                 -> (f -> Doc)-                 -> Int-                 -> formula-                 -> Doc-prettyFirstOrder pv pp pf prec formula =+prettyFirstOrder :: forall formula atom v. (FirstOrderFormula formula atom v) =>+                      (Int -> atom -> Doc) -> (v -> Doc) -> Int -> formula -> Doc+prettyFirstOrder pa pv prec formula =     foldFirstOrder-          (\ qop v f -> parensIf (prec > 1) $ prettyQuant qop <> pv v <+> prettyFirstOrder pv pp pf 1 f)+          (\ qop v f -> parensIf (prec > 1) $ prettyQuant qop <> pv v <+> prettyFirstOrder pa pv 1 f)           (\ cm ->                case cm of                  (BinOp f1 op f2) ->                      case op of-                       (:=>:) -> parensIf (prec > 2) $ (prettyFirstOrder pv pp pf 2 f1 <+> formOp op <+> prettyFirstOrder pv pp pf 2 f2)-                       (:<=>:) -> parensIf (prec > 2) $ (prettyFirstOrder pv pp pf 2 f1 <+> formOp op <+> prettyFirstOrder pv pp pf 2 f2)-                       (:&:) -> parensIf (prec > 3) $ (prettyFirstOrder pv pp pf 3 f1 <+> formOp op <+> prettyFirstOrder pv pp pf 3 f2)-                       (:|:) -> parensIf {-(prec > 4)-} True $ (prettyFirstOrder pv pp pf 4 f1 <+> formOp op <+> prettyFirstOrder pv pp pf 4 f2)-                 ((:~:) f) -> text {-"¬"-} "~" <> prettyFirstOrder pv pp pf 5 f)-          pr+                       (:=>:) -> parensIf (prec > 2) $ (prettyFirstOrder pa pv 2 f1 <+> formOp op <+> prettyFirstOrder pa pv 2 f2)+                       (:<=>:) -> parensIf (prec > 2) $ (prettyFirstOrder pa pv 2 f1 <+> formOp op <+> prettyFirstOrder pa pv 2 f2)+                       (:&:) -> parensIf (prec > 3) $ (prettyFirstOrder pa pv 3 f1 <+> formOp op <+> prettyFirstOrder pa pv 3 f2)+                       (:|:) -> parensIf {-(prec > 4)-} True $ (prettyFirstOrder pa pv 4 f1 <+> formOp op <+> prettyFirstOrder pa pv 4 f2)+                 ((:~:) f) -> text {-"¬"-} "~" <> prettyFirstOrder pa pv 5 f)+          (text . ifElse "true" "false")+          (pa 6)           formula     where-      pr :: Predicate p term -> Doc-      pr (Constant x) = text (show x)-      pr (Equal t1 t2) = parensIf (prec > 6) (prettyTerm pv pf t1 <+> text "=" <+> prettyTerm pv pf t2)-      pr (NotEqual t1 t2) = parensIf (prec > 6) (prettyTerm pv pf t1 <+> text "!=" <+> prettyTerm pv pf t2)-      pr (Apply p ts) =-          pp p <> case ts of-                    [] -> empty-                    _ -> parens (hcat (intersperse (text ",") (map (prettyTerm pv pf) ts)))       parensIf False = id       parensIf _ = parens . nest 1-      prettyQuant All = text {-"∀"-} "!"+      prettyQuant Forall = text {-"∀"-} "!"       prettyQuant Exists = text {-"∃"-} "?"       formOp (:<=>:) = text "<=>"       formOp (:=>:) = text "=>"       formOp (:&:) = text "&"       formOp (:|:) = text "|" +-- | 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)+ $(deriveSafeCopy 1 'base ''Quant)-$(deriveSafeCopy 1 'base ''Predicate)  $(deriveNewData [''Quant])-$(deriveNewData [''Predicate])+
Data/Logic/Classes/Literal.hs view
@@ -1,76 +1,97 @@-{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, UndecidableInstances #-} {-# OPTIONS -Wwarn #-} module Data.Logic.Classes.Literal     ( Literal(..)-    , PredicateLit(..)+    , zipLiterals     , fromFirstOrder+    , fromLiteral     , prettyLit     ) where -import Data.Generics (Data)-import Data.List (intersperse)-import Data.Logic.Classes.Boolean-import Data.Logic.Classes.FirstOrder-import Data.Logic.Classes.Negatable-import Data.Logic.Classes.Propositional (Combine(..))-import Data.Logic.Classes.Term-import Text.PrettyPrint (Doc, (<>), (<+>), text, empty, parens, hcat, nest)+import Data.Logic.Classes.Combine (Combination(..))+import Data.Logic.Classes.Constants+import qualified Data.Logic.Classes.FirstOrder as FOF+import Data.Logic.Classes.Negate+import Text.PrettyPrint (Doc, (<>), text)  -- |Literals are the building blocks of the clause and implicative normal -- |forms.  They support negation and must include True and False elements.-class ( Ord lit-      , Eq p-      , Ord p-      , Boolean p-      , Term term v f-      , Negatable lit-      , Data lit-      , Show lit-      ) => Literal lit term v p f | lit -> term, lit -> v, lit -> p, lit -> f where-    equals :: term -> term -> lit-    pAppLiteral :: p -> [term] -> lit-    foldLiteral :: (lit -> r) -> (PredicateLit p term -> r) -> lit -> r-    zipLiterals :: (lit -> lit -> Maybe r) -> (PredicateLit p term -> PredicateLit p term -> Maybe r) -> lit -> lit -> Maybe r+class (Negatable lit, Constants lit) => Literal lit atom v | lit -> atom v where+    foldLiteral :: (lit -> r) -> (Bool -> r) -> (atom -> r) -> lit -> r+    atomic :: atom -> lit --- |Helper type to implement the fold function for 'Literal'.-data PredicateLit p term-    = ApplyLit p [term]-    | EqualLit term term+zipLiterals :: Literal lit atom v =>+               (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+-}+ -- |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 term v p f lit term2 v2 p2 f2.-                  (FirstOrderFormula formula term v p f, Literal lit term2 v2 p2 f2) =>-                  (v -> v2) -> (p -> p2) -> (f -> f2) -> formula -> lit-fromFirstOrder cv cp cf formula =-    foldFirstOrder (\ _ _ _ -> error "toLiteral q") c p formula+fromFirstOrder :: forall formula atom v lit atom2 v2.+                  (FOF.FirstOrderFormula formula atom v, Literal lit atom2 v2) =>+                  (atom -> atom2) -> (v -> v2) -> formula -> lit+fromFirstOrder ca cv formula =+    FOF.foldFirstOrder (\ _ _ _ -> error "FirstOrder -> Literal") co fromBool (atomic . ca) formula     where-      c :: Combine formula -> lit-      c ((:~:) f) =  (.~.) (fromFirstOrder cv cp cf f)-      c _ = error "fromFirstOrder"-      p :: Predicate p term -> lit-      p (Equal a b) = ct a `equals` ct b-      p (NotEqual a b) = (.~.) (ct a `equals` ct b)-      p (Apply pr ts) = pAppLiteral (cp pr) (map ct ts)-      p (Constant b) = error $ "fromFirstOrder " ++ show b-      ct = convertTerm cv cf+      co :: Combination formula -> lit+      co ((:~:) f) =  (.~.) (fromFirstOrder ca cv f)+      co _ = error "FirstOrder -> Literal" -prettyLit :: forall lit term v p f. (Literal lit term v p f) =>+fromLiteral :: forall lit atom v fof atom2 v2. (Literal lit atom v, FOF.FirstOrderFormula fof atom2 v2) =>+               (atom -> atom2) -> lit -> fof+fromLiteral ca lit = foldLiteral (\ p -> (.~.) (fromLiteral ca p)) fromBool (FOF.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 c p lit+prettyLit pv pp pf _prec lit =+    foldLiteral neg tf at lit     where-      c x = if negated x then text {-"¬"-} "~" <> prettyLit pv pp pf 5 x else prettyLit pv pp pf 5 x-      p (ApplyLit pr ts) =-          pp pr <> case ts of-                        [] -> empty-                        _ -> parens (hcat (intersperse (text ",") (map (prettyTerm pv pf) ts)))-      p (EqualLit t1 t2) = parensIf (prec > 6) (prettyTerm pv pf t1 <+> text "=" <+> prettyTerm pv pf t2)-      parensIf False = id-      parensIf _ = parens . nest 1+      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 v) =>+              (Int -> atom -> Doc)+           -> (v -> Doc)+           -> Int+           -> lit+           -> Doc+prettyLit pa pv prec lit =+    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
− Data/Logic/Classes/Logic.hs 
@@ -1,43 +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.-module Data.Logic.Classes.Logic where--import Data.Logic.Classes.Negatable---- |A type class for logical formulas.  Minimal implementation:--- @---  (.|.), (.~.)--- @-class (Negatable formula, Ord formula) => Logic 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 2  .<=>. ,  .=>. ,  .<~>.-infixl 3  .&.-infixl 4  .|.  -- a & b | c means a & (b | c), which in cnf would be [[a], [b, c]]
− Data/Logic/Classes/Negatable.hs 
@@ -1,10 +0,0 @@-module Data.Logic.Classes.Negatable 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-    -- | Is this negated at the top level?-    negated :: formula -> Bool-    -- | Negation (This needs to check for and remove double negation)-    (.~.) :: formula -> formula
+ Data/Logic/Classes/Negate.hs view
@@ -0,0 +1,42 @@+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/Pred.hs 
@@ -1,42 +0,0 @@-{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses, ScopedTypeVariables #-}-module Data.Logic.Classes.Pred where--import Data.Logic.Classes.Arity-import Data.Logic.Classes.Boolean-import Data.Logic.Classes.Logic-import Data.Logic.Classes.Negatable---- |A class of predicates-class (Logic formula, Boolean p, Arity p) => Pred p term formula | formula -> p, formula -> term where-    pApp0 :: p  -> formula-    pApp1 :: p -> term -> formula-    pApp2 :: p -> term -> term -> formula-    pApp3 :: p -> term -> term -> term -> formula-    pApp4 :: p -> term -> term -> term -> term -> formula-    pApp5 :: p -> term -> term -> term -> term -> term -> formula-    pApp6 :: p -> term -> term -> term -> term -> term -> term -> formula-    pApp7 :: p -> term -> term -> term -> term -> term -> term -> term -> formula-    -- | Equality of Terms-    (.=.) :: term -> term -> formula-    -- | Inequality of Terms-    (.!=.) :: term -> term -> formula-    a .!=. b = (.~.) (a .=. b)-    -- | The tautological formula-    true :: formula-    true = pApp0 (fromBool True :: p)-    -- | The inconsistant formula-    false :: formula-    false = pApp0 (fromBool False :: p)--pApp :: (Pred p term formula, Arity p) => p -> [term] -> formula-pApp p ts =-    case (ts, maybe (length ts) id (arity p)) of-      ([], 0) -> pApp0 p -      ([a], 1) -> pApp1 p a-      ([a,b], 2) -> pApp2 p a b-      ([a,b,c], 3) -> pApp3 p a b c-      ([a,b,c,d], 4) -> pApp4 p a b c d-      ([a,b,c,d,e], 5) -> pApp5 p a b c d e-      ([a,b,c,d,e,f], 6) -> pApp6 p a b c d e f-      ([a,b,c,d,e,f,g], 7) -> pApp7 p a b c d e f g-      _ -> error ("Arity error" {- ++ show (pretty p) ++ " " ++ intercalate " " (map (show . pretty) ts) -})
Data/Logic/Classes/Propositional.hs view
@@ -8,12 +8,11 @@ -- 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     , convertProp-    , BinOp(..)-    , Combine(..)     , combine     , negationNormalForm     , clauseNormalForm@@ -24,10 +23,9 @@     , disjunctiveNormalForm'     ) where -import Data.Generics (Data, Typeable)-import Data.Logic.Classes.Boolean-import Data.Logic.Classes.Negatable-import Data.Logic.Classes.Logic+import Data.Logic.Classes.Combine+import Data.Logic.Classes.Constants+import Data.Logic.Classes.Negate import Data.SafeCopy (base, deriveSafeCopy) import qualified Data.Set.Extra as Set import Happstack.Data (deriveNewData)@@ -40,26 +38,28 @@ -- 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.)-class (Logic formula, Boolean formula, Ord formula, Ord atom) => PropositionalFormula formula atom | formula -> atom where+class (Combinable formula, Constants formula) => PropositionalFormula formula atom | formula -> atom where     -- | Build an atomic formula from the atom type.     atomic :: atom -> formula     -- | 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 :: (Combine formula -> r)+    foldPropositional :: (Combination formula -> r)+                      -> (Bool -> r)                       -> (atom -> r)-                      -> formula-                      -> 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 c a formula+    foldPropositional co tf at formula     where-      c ((:~:) f) = "(.~.) " ++ parenForm f-      c (BinOp f1 op f2) = parenForm f1 ++ " " ++ showFormOp op ++ " " ++ parenForm f2-      a = showAtom+      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 (:=>:) = ".=>."@@ -73,65 +73,15 @@                 PropositionalFormula formula2 atom2) =>                (atom1 -> atom2) -> formula1 -> formula2 convertProp convertA formula =-    foldPropositional c a 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 --- |'Combine' 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 Combine formula-    = BinOp formula BinOp formula-    | (:~:) formula-    deriving (Eq,Ord,Read,Data,Typeable)---- | Represents the boolean logic binary operations, used in the--- Combine type above.-data BinOp-    = (:<=>:)  -- ^ Equivalence-    |  (:=>:)  -- ^ Implication-    |  (:&:)  -- ^ AND-    |  (:|:)  -- ^ OR-    deriving (Eq,Ord,Read,Data,Typeable,Enum,Bounded)---- |We need to implement read manually here due to--- <http://hackage.haskell.org/trac/ghc/ticket/4136>-{--instance Read BinOp where-    readsPrec _ s = -        map (\ (x, t) -> (x, drop (length t) s))-            (take 1 (dropWhile (\ (_, t) -> not (isPrefixOf t s)) prs))-        where-          prs = [((:<=>:), ":<=>:"),-                 ((:=>:), ":=>:"),-                 ((:&:), ":&:"),-                 ((:|:), ":|:")]--}--instance Show BinOp where-    show (:<=>:) = "(:<=>:)"-    show (:=>:) = "(:=>:)"-    show (:&:) = "(:&:)"-    show (:|:) = "(:|:)"---- | A helper function for building folds:--- @---   foldPropositional combine atomic--- @--- is a no-op.-combine :: Logic formula => Combine 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- -- | Simplify and recursively apply nnf.-negationNormalForm :: PropositionalFormula formula atom => formula -> formula+negationNormalForm :: (PropositionalFormula formula atom, Eq formula) => formula -> formula negationNormalForm = nnf . psimplify  -- |Eliminate => and <=> and move negations inwards:@@ -149,16 +99,16 @@ --  nnf :: PropositionalFormula formula atom => formula -> formula nnf fm =-    foldPropositional (nnfCombine fm) (\ _ -> fm) fm+    foldPropositional (nnfCombine fm) fromBool (\ _ -> fm) fm -nnfCombine :: PropositionalFormula r atom => r -> Combine r -> r-nnfCombine fm ((:~:) p) = foldPropositional nnfNotCombine (\ _ -> fm) p+nnfCombine :: PropositionalFormula r atom => r -> Combination r -> r+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 => Combine formula -> formula+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)@@ -166,16 +116,17 @@ 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 :: (PropositionalFormula formula atom, Eq formula) => formula -> formula psimplify fm =-    foldPropositional c a fm+    foldPropositional co tf at fm     where-      c ((:~:) p) = psimplify1 ((.~.) (psimplify p))-      c (BinOp p (:&:) q) = psimplify1 (psimplify p .&. psimplify q)-      c (BinOp p (:|:) q) = psimplify1 (psimplify p .|. psimplify q)-      c (BinOp p (:=>:) q) = psimplify1 (psimplify p .=>. psimplify q)-      c (BinOp p (:<=>:) q) = psimplify1 (psimplify p .<=>. psimplify q)-      a _ = fm+      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@@ -196,11 +147,11 @@ --  False <=> P -> ~P -- @ -- -psimplify1 :: forall formula atom. PropositionalFormula formula atom => formula -> formula+psimplify1 :: forall formula atom. (PropositionalFormula formula atom, Eq formula) => formula -> formula psimplify1 fm =-    foldPropositional simplifyCombine (\ _ -> fm) fm+    foldPropositional simplifyCombine (\ _ -> fm) (\ _ -> fm) fm     where-      simplifyCombine ((:~:) f) = foldPropositional simplifyNotCombine simplifyNotAtom f+      simplifyCombine ((:~:) f) = foldPropositional simplifyNotCombine (fromBool . not) simplifyNotAtom f       simplifyCombine (BinOp l op r) =           case (asBool l, op, asBool r) of             (Just True,  (:&:), _)            -> r@@ -223,20 +174,11 @@       simplifyNotCombine ((:~:) f) = f       simplifyNotCombine _ = fm       simplifyNotAtom x = (.~.) (atomic x)-      -- We don't require an Eq instance, but we do require Ord so that-      -- we can make sets.-      asBool :: formula -> Maybe Bool-      asBool x =-          case compare x (fromBool True) of-            EQ -> Just True-            _ -> case compare x (fromBool False) of-                   EQ -> Just False-                   _ -> Nothing -clauseNormalForm' :: (PropositionalFormula formula atom) => formula -> Set.Set (Set.Set formula)+clauseNormalForm' :: (PropositionalFormula formula atom, Ord formula) => formula -> Set.Set (Set.Set formula) clauseNormalForm' = simp purecnf . negationNormalForm -clauseNormalForm :: forall formula atom. (PropositionalFormula formula atom) => formula -> formula+clauseNormalForm :: forall formula atom. (PropositionalFormula formula atom, Ord formula) => formula -> formula clauseNormalForm formula =     case clean (lists cnf) of       [] -> fromBool True@@ -247,10 +189,10 @@       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' :: (PropositionalFormula formula atom, Ord formula) => formula -> Set.Set (Set.Set formula) clauseNormalFormAlt' = simp purecnf' . negationNormalForm -clauseNormalFormAlt :: forall formula atom. (PropositionalFormula formula atom) => formula -> formula+clauseNormalFormAlt :: forall formula atom. (PropositionalFormula formula atom, Ord formula) => formula -> formula clauseNormalFormAlt formula =     case clean (lists cnf) of       [] -> fromBool True@@ -260,7 +202,7 @@       lists = Set.toList . Set.map Set.toList       cnf = clauseNormalFormAlt' formula -disjunctiveNormalForm :: (PropositionalFormula formula atom) => formula -> formula+disjunctiveNormalForm :: (PropositionalFormula formula atom, Ord formula) => formula -> formula disjunctiveNormalForm formula =     case clean (lists dnf) of       [] -> fromBool False@@ -270,10 +212,10 @@       lists = Set.toList . Set.map Set.toList       dnf = disjunctiveNormalForm' formula -disjunctiveNormalForm' :: (PropositionalFormula formula atom) => formula -> Set.Set (Set.Set formula)+disjunctiveNormalForm' :: (PropositionalFormula formula atom, Eq formula, Ord formula) => formula -> Set.Set (Set.Set formula) disjunctiveNormalForm' = simp purednf . negationNormalForm -simp :: forall formula atom. (PropositionalFormula formula atom) =>+simp :: forall formula atom. (PropositionalFormula formula atom, Eq formula, Ord formula) =>         (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@@ -293,25 +235,25 @@     where (n, p) = Set.partition negated lits  --purecnf :: forall formula term v p f lit. (FirstOrderFormula formula term v p f, Literal lit term v p f) => formula -> Set.Set (Set.Set lit)-purecnf :: forall formula atom. PropositionalFormula formula atom => formula -> Set.Set (Set.Set formula)+purecnf :: forall formula atom. (PropositionalFormula formula atom, Eq formula, Ord formula) => 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 :: forall formula atom. (PropositionalFormula formula atom, Ord formula) => formula -> Set.Set (Set.Set formula) purednf fm =-    foldPropositional c (\ _ -> x)  fm+    foldPropositional c (\ _ -> x) (\ _ -> x)  fm     where-      c :: Combine formula -> Set.Set (Set.Set formula)+      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' :: forall formula atom. (PropositionalFormula formula atom, Eq formula, Ord formula) => formula -> Set.Set (Set.Set formula) purecnf' fm =-    foldPropositional c (\ _ -> x)  fm+    foldPropositional c (\ _ -> x) (\ _ -> x)  fm     where-      c :: Combine formula -> Set.Set (Set.Set formula)+      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@@ -319,6 +261,6 @@       x = Set.singleton (Set.singleton (convertProp id fm)) :: Set.Set (Set.Set formula)  $(deriveSafeCopy 1 'base ''BinOp)-$(deriveSafeCopy 1 'base ''Combine)+$(deriveSafeCopy 1 'base ''Combination) -$(deriveNewData [''BinOp, ''Combine])+$(deriveNewData [''BinOp, ''Combination])
Data/Logic/Classes/Term.hs view
@@ -1,26 +1,37 @@ {-# 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.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 (Ord f, IsString f) => Function f where+--     variantF :: f -> Set.Set f -> f+ class ( Ord v     -- Required so variables can be inserted into maps and sets       , Variable v -- Used to rename variable during conversion to prenex       , Data v    -- For serialization+      -- , Function f       , Eq f      -- We need to check functions for equality during unification       , Skolem f  -- Used to create skolem functions and constants       , Data f    -- For serialization       , Ord term  -- For implementing Ord in Literal-      ) => Term term v f | term -> v, term -> f where-    var :: v -> term+      ) => 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@@@ -30,7 +41,7 @@     -- ^ 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.-    zipT :: (v -> v -> Maybe r) -> (f -> [term] -> f -> [term] -> Maybe r) -> term -> term -> Maybe r+    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,@@ -40,7 +51,7 @@     foldTerm v fn term     where       convertTerm' = convertTerm convertV convertF-      v = var . convertV+      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) =>@@ -49,7 +60,7 @@     foldTerm v f term     where       v :: v -> String-      v v' = "var (" ++ show v' ++ ")"+      v v' = "vt (" ++ show v' ++ ")"       f :: f -> [term] -> String       f fn ts = "fApp (" ++ show fn ++ ") [" ++ intercalate "," (map showTerm ts) ++ "]" @@ -59,3 +70,19 @@            -> 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 view
@@ -1,4 +1,36 @@ module Data.Logic.Classes.Variable+    ( Variable(..)+    , variants+    , showVariable+    ) where++import qualified Data.Set as Set+import Data.String (IsString)+import Text.PrettyPrint (Doc)++class (Ord v, IsString 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)) ++ ")"++{-+module Data.Logic.Classes.Variable     ( Variable(one, next)     , variant     ) where@@ -21,3 +53,4 @@ -- a monad, just pass in the set of free variables.) variant :: (Variable v, Ord v) => S.Set v -> v -> v variant names x = if S.member x names then variant names (next x) else x+-}
+ Data/Logic/Harrison/Equal.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, 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 Control.Applicative.Error (Failing(..))+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.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+    [(∀) (fromString "x") (x .=. x),+     (∀) (fromString "x") ((∀) (fromString "y") ((∀) (fromString "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 :: (FirstOrderFormula formula atom v, AtomEq atom t term, Term term v f, Ord t, 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)+      allpreds = predicates fm+      preds = Set.delete Equals allpreds++-- ------------------------------------------------------------------------- +-- 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 view
@@ -0,0 +1,271 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeSynonymInstances #-}+{-# OPTIONS_GHC -Wall #-}+module Data.Logic.Harrison.FOL+    ( eval+    , list_disj+    , list_conj+    , var+    , fv+    , subst+    , generalize+    ) where++import Data.Logic.Classes.Apply (Apply(..), apply)+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(allVariables, substitute))+import Data.Logic.Classes.Negate ((.~.))+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 :: (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))) 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, Formula atom term v) => formula -> Set.Set v+var fm =+    foldFirstOrder qu co tf allVariables 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++-- | Return the variables that occur free in a formula.+fv :: forall formula atom term v. (FirstOrderFormula formula atom v, Formula atom term v) => formula -> Set.Set v+fv fm =+    foldFirstOrder qu co tf allVariables 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++-- ------------------------------------------------------------------------- +-- Universal closure of a formula.                                           +-- ------------------------------------------------------------------------- ++generalize :: (FirstOrderFormula formula atom v, Formula 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, Formula atom term v, Term term v f) =>+         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++{-+-- |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
@@ -0,0 +1,211 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, DeriveDataTypeable, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -Wwarn #-}+module Data.Logic.Harrison.Formulas.FirstOrder+    ( antecedent+    , consequent+    , on_atoms+    , over_atoms+    , atom_union+    ) where++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.                                      +-- ------------------------------------------------------------------------- ++{-+let rec parse_ginfix opsym opupdate sof subparser inp =+  let e1,inp1 = subparser inp in+  if inp1 <> [] & hd inp1 = opsym then+     parse_ginfix opsym opupdate (opupdate sof e1) subparser (tl inp1)+  else sof e1,inp1;;++let parse_left_infix opsym opcon =+  parse_ginfix opsym (fun f e1 e2 -> opcon(f e1,e2)) (fun x -> x);;++let parse_right_infix opsym opcon =+  parse_ginfix opsym (fun f e1 e2 -> f(opcon(e1,e2))) (fun x -> x);;++let parse_list opsym =+  parse_ginfix opsym (fun f e1 e2 -> (f e1)@[e2]) (fun x -> [x]);;++-- ------------------------------------------------------------------------- +-- Other general parsing combinators.                                        +-- ------------------------------------------------------------------------- ++let papply f (ast,rest) = (f ast,rest);;++let nextin inp tok = inp <> [] & hd inp = tok;;++let parse_bracketed subparser cbra inp =+  let ast,rest = subparser inp in+  if nextin rest cbra then ast,tl rest+  else failwith "Closing bracket expected";;++-- ------------------------------------------------------------------------- +-- Parsing of formulas, parametrized by atom parser "pfn".                   +-- ------------------------------------------------------------------------- ++let rec parse_atomic_formula (ifn,afn) vs inp =+  match inp with+    [] -> failwith "formula expected"+  | "false"::rest -> False,rest+  | "true"::rest -> True,rest+  | "("::rest -> (try ifn vs inp with Failure _ ->+                  parse_bracketed (parse_formula (ifn,afn) vs) ")" rest)+  | "~"::rest -> papply (fun p -> Not p)+                        (parse_atomic_formula (ifn,afn) vs rest)+  | "forall"::x::rest ->+        parse_quant (ifn,afn) (x::vs) (fun (x,p) -> Forall(x,p)) x rest+  | "exists"::x::rest ->+        parse_quant (ifn,afn) (x::vs) (fun (x,p) -> Exists(x,p)) x rest+  | _ -> afn vs inp++and parse_quant (ifn,afn) vs qcon x inp =+   match inp with+     [] -> failwith "Body of quantified term expected"+   | y::rest ->+        papply (fun fm -> qcon(x,fm))+               (if y = "." then parse_formula (ifn,afn) vs rest+                else parse_quant (ifn,afn) (y::vs) qcon y rest)++and parse_formula (ifn,afn) vs inp =+   parse_right_infix "<=>" (fun (p,q) -> Iff(p,q))+     (parse_right_infix "==>" (fun (p,q) -> Imp(p,q))+         (parse_right_infix "\\/" (fun (p,q) -> Or(p,q))+             (parse_right_infix "/\\" (fun (p,q) -> And(p,q))+                  (parse_atomic_formula (ifn,afn) vs)))) inp;;++-- ------------------------------------------------------------------------- +-- Printing of formulas, parametrized by atom printer.                       +-- ------------------------------------------------------------------------- ++let bracket p n f x y =+  (if p then print_string "(" else ());+  open_box n; f x y; close_box();+  (if p then print_string ")" else ());;++let rec strip_quant fm =+  match fm with+    Forall(x,(Forall(y,p) as yp)) | Exists(x,(Exists(y,p) as yp)) ->+        let xs,q = strip_quant yp in x::xs,q+  |  Forall(x,p) | Exists(x,p) -> [x],p+  | _ -> [],fm;;++let print_formula pfn =+  let rec print_formula pr fm =+    match fm with+      False -> print_string "false"+    | True -> print_string "true"+    | Atom(pargs) -> pfn pr pargs+    | Not(p) -> bracket (pr > 10) 1 (print_prefix 10) "~" p+    | And(p,q) -> bracket (pr > 8) 0 (print_infix 8 "/\\") p q+    | Or(p,q) ->  bracket (pr > 6) 0 (print_infix  6 "\\/") p q+    | Imp(p,q) ->  bracket (pr > 4) 0 (print_infix 4 "==>") p q+    | Iff(p,q) ->  bracket (pr > 2) 0 (print_infix 2 "<=>") p q+    | Forall(x,p) -> bracket (pr > 0) 2 print_qnt "forall" (strip_quant fm)+    | Exists(x,p) -> bracket (pr > 0) 2 print_qnt "exists" (strip_quant fm)+  and print_qnt qname (bvs,bod) =+    print_string qname;+    do_list (fun v -> print_string " "; print_string v) bvs;+    print_string "."; print_space(); open_box 0;+    print_formula 0 bod;+    close_box()+  and print_prefix newpr sym p =+   print_string sym; print_formula (newpr+1) p+  and print_infix newpr sym p q =+    print_formula (newpr+1) p;+    print_string(" "^sym); print_space();+    print_formula newpr q in+  print_formula 0;;++let print_qformula pfn fm =+  open_box 0; print_string "<<";+  open_box 0; print_formula pfn fm; close_box();+  print_string ">>"; close_box();;++-- ------------------------------------------------------------------------- +-- OCaml won't let us use the constructors.                                  +-- ------------------------------------------------------------------------- ++let mk_and p q = And(p,q) and mk_or p q = Or(p,q)+and mk_imp p q = Imp(p,q) and mk_iff p q = Iff(p,q)+and mk_forall x p = Forall(x,p) and mk_exists x p = Exists(x,p);;++-- ------------------------------------------------------------------------- +-- Destructors.                                                              +-- ------------------------------------------------------------------------- ++let dest_iff fm =+  match fm with Iff(p,q) -> (p,q) | _ -> failwith "dest_iff";;++let dest_and fm =+  match fm with And(p,q) -> (p,q) | _ -> failwith "dest_and";;++let rec conjuncts fm =+  match fm with And(p,q) -> conjuncts p @ conjuncts q | _ -> [fm];;++let dest_or fm =+  match fm with Or(p,q) -> (p,q) | _ -> failwith "dest_or";;++let rec disjuncts fm =+  match fm with Or(p,q) -> disjuncts p @ disjuncts q | _ -> [fm];;++let dest_imp fm =+  match fm with Imp(p,q) -> (p,q) | _ -> failwith "dest_imp";;+-}++antecedent :: FirstOrderFormula formula atom v => formula -> formula+antecedent formula =+    foldFirstOrder (\ _ _ _ -> err) c (\ _ -> err) (\ _ -> err) formula+    where+      c (BinOp p (:=>:) _) = p+      c _ = err+      err = error "antecedent"++consequent :: FirstOrderFormula formula atom v => formula -> formula+consequent formula =+    foldFirstOrder (\ _ _ _ -> err) c (\ _ -> err) (\ _ -> err) formula+    where+      c (BinOp _ (:=>:) 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 f fm =+    foldFirstOrder qu co 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)+      tf _ = fm+      at = f++-- ------------------------------------------------------------------------- +-- Formula analog of list iterator "itlist".                                 +-- ------------------------------------------------------------------------- ++over_atoms :: FirstOrderFormula formula atom v => (atom -> b -> b) -> formula -> b -> b+over_atoms f fm b =+    foldFirstOrder qu co 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)+      tf _ = b+      pr atom = f atom b++-- ------------------------------------------------------------------------- +-- 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 f fm = over_atoms (\ h t -> Set.union (f h) t) fm Set.empty
+ Data/Logic/Harrison/Formulas/Propositional.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, DeriveDataTypeable, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -Wwarn #-}+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(..))++-- ------------------------------------------------------------------------- +-- General parsing of iterated infixes.                                      +-- ------------------------------------------------------------------------- ++{-+let rec parse_ginfix opsym opupdate sof subparser inp =+  let e1,inp1 = subparser inp in+  if inp1 <> [] & hd inp1 = opsym then+     parse_ginfix opsym opupdate (opupdate sof e1) subparser (tl inp1)+  else sof e1,inp1;;++let parse_left_infix opsym opcon =+  parse_ginfix opsym (fun f e1 e2 -> opcon(f e1,e2)) (fun x -> x);;++let parse_right_infix opsym opcon =+  parse_ginfix opsym (fun f e1 e2 -> f(opcon(e1,e2))) (fun x -> x);;++let parse_list opsym =+  parse_ginfix opsym (fun f e1 e2 -> (f e1)@[e2]) (fun x -> [x]);;++-- ------------------------------------------------------------------------- +-- Other general parsing combinators.                                        +-- ------------------------------------------------------------------------- ++let papply f (ast,rest) = (f ast,rest);;++let nextin inp tok = inp <> [] & hd inp = tok;;++let parse_bracketed subparser cbra inp =+  let ast,rest = subparser inp in+  if nextin rest cbra then ast,tl rest+  else failwith "Closing bracket expected";;++-- ------------------------------------------------------------------------- +-- Parsing of formulas, parametrized by atom parser "pfn".                   +-- ------------------------------------------------------------------------- ++let rec parse_atomic_formula (ifn,afn) vs inp =+  match inp with+    [] -> failwith "formula expected"+  | "false"::rest -> False,rest+  | "true"::rest -> True,rest+  | "("::rest -> (try ifn vs inp with Failure _ ->+                  parse_bracketed (parse_formula (ifn,afn) vs) ")" rest)+  | "~"::rest -> papply (fun p -> Not p)+                        (parse_atomic_formula (ifn,afn) vs rest)+  | "forall"::x::rest ->+        parse_quant (ifn,afn) (x::vs) (fun (x,p) -> Forall(x,p)) x rest+  | "exists"::x::rest ->+        parse_quant (ifn,afn) (x::vs) (fun (x,p) -> Exists(x,p)) x rest+  | _ -> afn vs inp++and parse_quant (ifn,afn) vs qcon x inp =+   match inp with+     [] -> failwith "Body of quantified term expected"+   | y::rest ->+        papply (fun fm -> qcon(x,fm))+               (if y = "." then parse_formula (ifn,afn) vs rest+                else parse_quant (ifn,afn) (y::vs) qcon y rest)++and parse_formula (ifn,afn) vs inp =+   parse_right_infix "<=>" (fun (p,q) -> Iff(p,q))+     (parse_right_infix "==>" (fun (p,q) -> Imp(p,q))+         (parse_right_infix "\\/" (fun (p,q) -> Or(p,q))+             (parse_right_infix "/\\" (fun (p,q) -> And(p,q))+                  (parse_atomic_formula (ifn,afn) vs)))) inp;;++-- ------------------------------------------------------------------------- +-- Printing of formulas, parametrized by atom printer.                       +-- ------------------------------------------------------------------------- ++let bracket p n f x y =+  (if p then print_string "(" else ());+  open_box n; f x y; close_box();+  (if p then print_string ")" else ());;++let rec strip_quant fm =+  match fm with+    Forall(x,(Forall(y,p) as yp)) | Exists(x,(Exists(y,p) as yp)) ->+        let xs,q = strip_quant yp in x::xs,q+  |  Forall(x,p) | Exists(x,p) -> [x],p+  | _ -> [],fm;;++let print_formula pfn =+  let rec print_formula pr fm =+    match fm with+      False -> print_string "false"+    | True -> print_string "true"+    | Atom(pargs) -> pfn pr pargs+    | Not(p) -> bracket (pr > 10) 1 (print_prefix 10) "~" p+    | And(p,q) -> bracket (pr > 8) 0 (print_infix 8 "/\\") p q+    | Or(p,q) ->  bracket (pr > 6) 0 (print_infix  6 "\\/") p q+    | Imp(p,q) ->  bracket (pr > 4) 0 (print_infix 4 "==>") p q+    | Iff(p,q) ->  bracket (pr > 2) 0 (print_infix 2 "<=>") p q+    | Forall(x,p) -> bracket (pr > 0) 2 print_qnt "forall" (strip_quant fm)+    | Exists(x,p) -> bracket (pr > 0) 2 print_qnt "exists" (strip_quant fm)+  and print_qnt qname (bvs,bod) =+    print_string qname;+    do_list (fun v -> print_string " "; print_string v) bvs;+    print_string "."; print_space(); open_box 0;+    print_formula 0 bod;+    close_box()+  and print_prefix newpr sym p =+   print_string sym; print_formula (newpr+1) p+  and print_infix newpr sym p q =+    print_formula (newpr+1) p;+    print_string(" "^sym); print_space();+    print_formula newpr q in+  print_formula 0;;++let print_qformula pfn fm =+  open_box 0; print_string "<<";+  open_box 0; print_formula pfn fm; close_box();+  print_string ">>"; close_box();;++-- ------------------------------------------------------------------------- +-- OCaml won't let us use the constructors.                                  +-- ------------------------------------------------------------------------- ++let mk_and p q = And(p,q) and mk_or p q = Or(p,q)+and mk_imp p q = Imp(p,q) and mk_iff p q = Iff(p,q)+and mk_forall x p = Forall(x,p) and mk_exists x p = Exists(x,p);;++-- ------------------------------------------------------------------------- +-- Destructors.                                                              +-- ------------------------------------------------------------------------- ++let dest_iff fm =+  match fm with Iff(p,q) -> (p,q) | _ -> failwith "dest_iff";;++let dest_and fm =+  match fm with And(p,q) -> (p,q) | _ -> failwith "dest_and";;++let rec conjuncts fm =+  match fm with And(p,q) -> conjuncts p @ conjuncts q | _ -> [fm];;++let dest_or fm =+  match fm with Or(p,q) -> (p,q) | _ -> failwith "dest_or";;++let rec disjuncts fm =+  match fm with Or(p,q) -> disjuncts p @ disjuncts q | _ -> [fm];;++let dest_imp fm =+  match fm with Imp(p,q) -> (p,q) | _ -> failwith "dest_imp";;+-}++antecedent :: PropositionalFormula formula atomic => formula -> formula+antecedent formula =+    foldPropositional c (error "antecedent") (error "antecedent") formula+    where+      c (BinOp p (:=>:) _) = p+      c _ = error "antecedent"++consequent :: PropositionalFormula formula atomic => 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+    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
+ Data/Logic/Harrison/Lib.hs view
@@ -0,0 +1,826 @@+{-# LANGUAGE RankNTypes #-}+{-# 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+    , image+    , optimize+    , minimize+    , maximize+    , can+    , allsubsets+    , allnonemptysubsets+    , mapfilter+    , setmapfilter+    , (∅)+    ) where++import Control.Applicative.Error (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++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] -> a+optimize ord f l =+  fst (end_itlist (\ 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] -> a+maximize f l = optimize (>) f l++minimize :: forall a b. Ord b => (a -> b) -> [a] -> a+minimize f l = optimize (<) f l++-- -------------------------------------------------------------------------+-- 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.                       *)+(* ------------------------------------------------------------------------- *)++let rec allsets m l =+  if m = 0 then [[]] else+  match l with+    [] -> []+  | h::t -> union (image (fun g -> h::g) (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 view
@@ -0,0 +1,546 @@+{-# 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.Constants (Constants, false)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..))+import Data.Logic.Classes.Formula (Formula)+import Data.Logic.Classes.Literal (Literal, fromLiteral)+import Data.Logic.Classes.Negate ((.~.), negative)+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 v, Term term v f, Formula 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 v, Term term v f, Formula 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, Literal fof atom v, Term term v f, Formula 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++{-+-- ------------------------------------------------------------------------- +-- 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 view
@@ -0,0 +1,139 @@+{-# 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(..))+import Data.Logic.Classes.Formula (Formula)+import Data.Logic.Classes.Literal (Literal(atomic), fromFirstOrder, fromLiteral)+import Data.Logic.Classes.Negate (Negatable, negated, (.~.))+import Data.Logic.Classes.Term (Term)+import Data.Logic.Harrison.Lib (setAny, allpairs)+import Data.Logic.Harrison.Skolem (nnf, simplify)+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 v, 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 . Data.Logic.Classes.Literal.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 v, 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 = Set.singleton (Set.singleton (fromFirstOrder id id fm)) -- :: Set.Set (Set.Set lit)++-- ------------------------------------------------------------------------- +-- 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 (Data.Logic.Classes.FirstOrder.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 v, Ord lit) => fof -> Set.Set (Set.Set lit)+simpcnf' fm =+    foldFirstOrder (\ _ _ _ -> cjs') co tf at fm+    where+      co _ = cjs'+      at = Set.singleton . Set.singleton . Data.Logic.Classes.Literal.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 v, Ord lit) => fof -> Set.Set (Set.Set lit)+purecnf' fm = Set.map (Set.map (.~.)) (purednf' (nnf ((.~.) fm)))
+ Data/Logic/Harrison/Prolog.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}+module Data.Logic.Harrison.Prolog where++import Data.Logic.Classes.FirstOrder (FirstOrderFormula)+import Data.Logic.Classes.Formula (Formula)+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 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 view
@@ -0,0 +1,418 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies #-}+{-# OPTIONS_GHC -Wall -Wwarn #-}+module Data.Logic.Harrison.Prop+    ( eval+    , atoms+    , onAllValuations+    , truthTable+    , tautology+    , unsatisfiable+    , satisfiable+    , rawdnf+    , purednf+    , dnf+    , trivial+    , psimplify+    , nnf+    -- , simpdnf+    , simpcnf+    , positive+    , negative+    , negate+    , distrib+    , list_disj+    , list_conj+    -- previously unexported+    , pSubst+    , dual+    , nenf+    , mkLits+    , allSatValuations+    , dnf0+    , cnf+    ) where++import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..), binop)+import Data.Logic.Classes.Constants (Constants(fromBool, true, false), asBool, ifElse)+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, allpairs, setAny)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Prelude hiding (negate)++-- ------------------------------------------------------------------------- +-- 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 => formula -> (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 = v x++{-+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 :: (Eq a) =>+                   (r -> r -> r)      -- ^ Combine function for result type+                -> ((a -> Bool) -> r) -- ^ The substitution function+                -> (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.deleteFindMin ps of+      (p, ps') -> append -- Do the valuations of the remaining variables with  set to false+                        (onAllValuations append subfn (\ q -> if q == p then False else v q) ps')+                        -- Do the valuations of the remaining variables with  set to true+                        (onAllValuations append subfn (\ q -> if q == p then True else v q) ps')++type TruthTableRow a = ([(a, Bool)], Bool)++truthTable :: forall formula atomic. (PropositionalFormula formula atomic, Eq atomic, Ord atomic) =>+              formula -> [TruthTableRow atomic]+truthTable fm =+    onAllValuations (++) mkRow (const False) ats+    where+      mkRow :: (atomic -> Bool)         -- The current variable assignment+            -> [TruthTableRow atomic] -- The variable assignments and the formula value+      mkRow v = [(map (\ a -> (a, v a)) (Set.toList ats), eval fm v)]+      ats = atoms fm++-- ------------------------------------------------------------------------- +-- Recognizing tautologies.                                                  +-- ------------------------------------------------------------------------- ++tautology :: (PropositionalFormula formula atomic, Ord atomic) => formula -> Bool+tautology fm = onAllValuations (&&) (eval fm) (const False) (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 :: PropositionalFormula formula atomic => formula -> Bool+negative lit =+    foldPropositional c tf a lit+    where+      c ((:~:) _) = True+      c _ = False+      tf = not+      a _ = False++positive :: PropositionalFormula formula atomic => formula -> 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++-- ------------------------------------------------------------------------- +-- 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) =>+          Set.Set formula -> (atomic -> Bool) -> formula+mkLits pvs v = list_conj (Set.map (\ p -> if eval p v then p else (.~.) p) pvs)++allSatValuations :: Eq a => ((a -> Bool) -> Bool) -> (a -> Bool) -> Set.Set a -> [a -> Bool]+allSatValuations subfn v pvs =+    case Set.minView pvs of+      Nothing -> if subfn v then [v] else []+      Just (p, ps) -> (allSatValuations subfn (\ q -> if q == p then False else v p) ps) +++                      (allSatValuations subfn (\ q -> if q == p then True else v p) 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) (const False) 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.                                    +-- ------------------------------------------------------------------------- ++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++purednf :: (PropositionalFormula formula atomic, Ord formula) => formula -> Set.Set (Set.Set formula)+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 _ = Set.singleton (Set.singleton fm)+      tf _ = Set.singleton (Set.singleton fm)+      a _ = Set.singleton (Set.singleton fm)++-- ------------------------------------------------------------------------- +-- Filtering out trivial disjuncts (in this guise, contradictory).           +-- ------------------------------------------------------------------------- ++trivial :: (PropositionalFormula formula atomic, Ord formula) => Set.Set formula -> 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 formula atomic.  (PropositionalFormula formula atomic, Eq formula, Ord formula) => formula -> Set.Set (Set.Set formula)+simpdnf fm =+    foldPropositional c tf a fm+    where+      c :: Combination formula -> Set.Set (Set.Set formula)+      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 :: atomic -> Set.Set (Set.Set formula)+      a _ = Set.singleton (Set.singleton fm)++-- ------------------------------------------------------------------------- +-- Mapping back to a formula.                                                +-- ------------------------------------------------------------------------- ++dnf :: (PropositionalFormula formula atomic, Ord formula) => formula -> formula+dnf fm = list_disj (Set.map list_conj (simpdnf fm))++-- ------------------------------------------------------------------------- +-- Conjunctive normal form (CNF) by essentially the same code.               +-- ------------------------------------------------------------------------- ++purecnf :: (PropositionalFormula formula atomic, Ord formula) => formula -> Set.Set (Set.Set formula)+purecnf fm = Set.map (Set.map (psimplify . (.~.))) (purednf (nnf ((.~.) fm)))++simpcnf :: (PropositionalFormula formula atomic, Ord formula) =>+           formula -> Set.Set (Set.Set formula)+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 _ = Set.singleton (Set.singleton fm)++cnf :: (PropositionalFormula formula atomic, Ord formula) => formula -> formula+cnf fm = list_conj (Set.map list_disj (simpcnf fm))
+ Data/Logic/Harrison/Resolution.hs view
@@ -0,0 +1,1041 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}+module Data.Logic.Harrison.Resolution where++import Control.Applicative.Error (Failing(..), failing)+import Data.Logic.Classes.Combine (Combination(..))+import Data.Logic.Classes.Equals (AtomEq, zipAtomsEq)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), zipFirstOrder)+import Data.Logic.Classes.Formula (Formula(match))+import Data.Logic.Classes.Literal (Literal)+import Data.Logic.Classes.Negate ((.~.), positive)+import Data.Logic.Classes.Term (Term(vt, foldTerm))+import Data.Logic.Classes.Variable (Variable(prefix))+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 v, Term term v f, Formula 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 v, Term term v f, Formula 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, Formula 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 v, FirstOrderFormula fof atom v, Term term v f, Formula 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 v, FirstOrderFormula fof atom v, Term term v f, Formula 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 v, FirstOrderFormula fof atom v, Term term v f, Formula atom term v, Ord fof) =>+            (Map.Map v term -> atom -> atom -> Failing (Map.Map v term))+         -> Set.Set (Set.Set fof) -> Set.Set (Set.Set fof) -> Failing Bool+resloop1 ua 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 ua 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 v, FirstOrderFormula fof atom v, Term term v f, Formula atom term v, Ord fof) =>+                    (Map.Map v term -> atom -> atom -> Failing (Map.Map v term))+                 -> fof -> Failing Bool+pure_resolution1 ua fm = resloop1 ua Set.empty (simpcnf (specialize (pnf fm)))++resolution1 :: forall m fof term f atom v.+               (Literal fof atom v,+                FirstOrderFormula fof atom v,+                Term term v f,+                Formula atom term v,+                Ord fof,+                Monad m) =>+               (Map.Map v term -> atom -> atom -> Failing (Map.Map v term))+            -> fof+            -> SkolemT v term m (Set.Set (Failing Bool))+resolution1 ua fm =+    askolemize ((.~.)(generalize fm)) >>=+    return . Set.map (pure_resolution1 ua . list_conj) . simpdnf++-- ------------------------------------------------------------------------- +-- 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, Formula 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, Formula 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, Formula 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, Formula 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 v, FirstOrderFormula fof atom v, Term term v f, Formula 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 v, FirstOrderFormula fof atom v, Term term v f, Formula atom term v, Ord fof) =>+                    fof -> Failing Bool+pure_resolution2 fm = resloop2 Set.empty (simpcnf (specialize (pnf fm)))++resolution2 :: (Literal fof atom v, FirstOrderFormula fof atom v, Term term v f, Formula 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++-- ------------------------------------------------------------------------- +-- Positive (P1) resolution.                                                 +-- ------------------------------------------------------------------------- ++presolve_clauses :: (Literal fof atom v, FirstOrderFormula fof atom v, Term term v f, Formula 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 v, FirstOrderFormula fof atom v, Term term v f, Formula 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 v, FirstOrderFormula fof atom v, Term term v f, Formula atom term v, Ord fof) =>+                    fof -> Failing Bool+pure_presolution fm = presloop Set.empty (simpcnf (specialize (pnf fm)))++presolution :: (Literal fof atom v, FirstOrderFormula fof atom v, Term term v f, Formula 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++-- ------------------------------------------------------------------------- +-- Introduce a set-of-support restriction.                                   +-- ------------------------------------------------------------------------- ++pure_resolution3 :: (Literal fof atom v, FirstOrderFormula fof atom v, Term term v f, Formula atom term v, Ord fof) =>+                    fof -> Failing Bool+pure_resolution3 fm =+    uncurry resloop2 (Set.partition (setAny positive) (simpcnf (specialize (pnf fm))))++resolution3 :: (Literal fof atom v, FirstOrderFormula fof atom v, Term term v f, Formula 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+{-+-- ------------------------------------------------------------------------- +-- 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 view
@@ -0,0 +1,307 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies #-}+{-# OPTIONS_GHC -Wall #-}+module Data.Logic.Harrison.Skolem+    ( simplify+    , lsimplify+    , nnf+    , pnf+    , functions+    , SkolemT+    , runSkolem+    , runSkolemT+    , specialize+    , skolemize+    , literal+    , askolemize+    , skolemNormalForm+    -- , substituteEq+    ) where++import Control.Monad.Identity (Identity(runIdentity))+import Control.Monad.State (StateT(runStateT), get, put)+import Data.Logic.Classes.Apply (Apply(foldApply))+import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..), binop)+import Data.Logic.Classes.Constants (Constants(fromBool, true, false), asBool)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(exists, for_all, foldFirstOrder), Quant(..), quant)+import Data.Logic.Classes.Formula (Formula)+import Data.Logic.Classes.Literal (Literal(foldLiteral, atomic))+import Data.Logic.Classes.Negate ((.~.))+import Data.Logic.Classes.Skolem (Skolem(toSkolem))+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 atom term v, Term term v f, Eq fof) =>+             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) =+          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+      nco ((:~:) p) = p+      nco _ = fm+      tf = fromBool+      at _ = fm++simplify :: (FirstOrderFormula fof atom v, Formula atom term v, Term term v f, Eq fof) =>+            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 v => lit -> lit+lsimplify fm = foldLiteral (lsimplify1 . (.~.) . lsimplify) fromBool (const fm) fm++lsimplify1 :: Literal lit atom v => 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 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, Formula 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 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, Formula atom term v, Term term v f, Eq formula) =>+       formula -> formula+pnf = prenex . nnf . simplify++-- ------------------------------------------------------------------------- +-- Get the functions in a term and formula.                                  +-- ------------------------------------------------------------------------- ++functions :: forall formula atom v f. (FirstOrderFormula formula atom v, Ord f) => (atom -> Set.Set (f, Int)) -> formula -> Set.Set (f, Int)+functions fa fm =+    foldFirstOrder qu co tf fa fm+    where+      qu _ _ p = functions fa p+      co ((:~:) p) = functions fa p+      co (BinOp p _ q) = Set.union (functions fa p) (functions fa q)+      tf _ = Set.empty++-- ------------------------------------------------------------------------- +-- 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.+      -- , skolemMap :: Map.Map v term+      --   -- ^ Map from variables to applications of a Skolem function+      , 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.+      }++newSkolemState :: SkolemState v term+newSkolemState = SkolemState { skolemCount = 1+                             -- , skolemMap = Map.empty+                             , univQuant = [] }++type SkolemT v term m = StateT (SkolemState v term) m++runSkolem :: SkolemT v term Identity a -> a+runSkolem = runIdentity . runSkolemT++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 formula atom v, Formula atom term v, Term term v f) =>+          formula -> SkolemT v term m formula+skolem fm =+    foldFirstOrder qu co (\ _ -> return fm) (\ _ -> return fm) fm+    where+      qu Exists y p =+          do let xs = fv fm+             state <- get+             let f = toSkolem (skolemCount state)+             put (state {skolemCount = skolemCount state + 1})+             let fx = fApp f (map vt (Set.toList 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 formula atom v, Formula atom term v, Term term v f) =>+           (formula -> formula -> formula) -> formula -> formula -> SkolemT v term m formula+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 :: (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f, Eq formula) =>+              formula -> SkolemT v term m formula+askolemize = skolem . nnf . simplify++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 :: (Monad m, FirstOrderFormula fof atom v, Formula atom term v, Term term v f, Eq fof) =>+             fof -> SkolemT v term m fof+skolemize fm = askolemize fm >>= return . 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 v, Apply atom p term, Term term v f, Literal lit atom v, 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 (Data.Logic.Classes.Literal.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,+                     Formula atom term v,+                     Term term v f,+                     Monad m, Eq fof) =>+                    fof -> SkolemT v term m fof+skolemNormalForm f = askolemize f >>= return . specialize . pnf
+ Data/Logic/Harrison/Tableaux.hs view
@@ -0,0 +1,574 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}+module Data.Logic.Harrison.Tableaux+    ( unify_literals+    , unifyAtomsEq+    , deepen+    ) where++import Control.Applicative.Error (Failing(..))+import Data.Logic.Classes.Equals (AtomEq, zipAtomsEq)+import qualified Data.Logic.Classes.Formula as C+import Data.Logic.Classes.Literal (Literal, zipLiterals)+import Data.Logic.Classes.Term (Term(..))+import Data.Logic.Harrison.Unif (unify)+import qualified Data.Map as Map+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 v, Term term v f, C.Formula atom term v) =>+                  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 env (p,q) = unify_literals env (p,negate q)++-- ------------------------------------------------------------------------- +-- Unify and refute a set of disjuncts.                                      +-- ------------------------------------------------------------------------- ++unify_refute djs env =+  case djs of+    [] -> env+    d : odjs -> let (pos,neg) = partition positive d in+               tryfind (unify_refute odjs . unify_complements env)+                       (allpairs (\ p q -> (p,q)) pos neg);;++-- ------------------------------------------------------------------------- +-- Hence a Prawitz-like procedure (using unification on DNF).                +-- ------------------------------------------------------------------------- ++prawitz_loop djs0 fvs djs n =+    let l = length fvs in+    let newvars = map (\ k -> "_" ++ show (n * l + k)) [1..l] in+    let inst = fpf fvs (map Var newvars) in+    let djs1 = distrib (image (image (subst inst)) djs0) djs in+    case (unify_refute djs1 undefined,(n + 1)) of+      Left _ -> prawitz_loop djs0 fvs djs1 (n + 1)+      Right x -> x++prawitz fm =+  let fm0 = skolemize(Not(generalize fm)) in+  snd(prawitz_loop (simpdnf fm0) (fv fm0) [[]] 0);;++-- ------------------------------------------------------------------------- +-- 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" [var "x"] .&. pApp "Q" [var "y"] .=>.+                                                                   pApp "R" [var "z"] .&. pApp "U" [var "w"]))))) .=>.+               (exists "x" (exists "y" (pApp "P" [var "x"] .&. pApp "Q" [var "y"]))) .=>. (exists "z" (pApp "R" [var "z"]))+          expected = false++-- ------------------------------------------------------------------------- +-- Comparison of number of ground instances.                                 +-- ------------------------------------------------------------------------- ++compare fm =+    (prawitz fm, davisputnam fm)+{-+START_INTERACTIVE;;+test02 = TestCase $ assertEqual "p19" expected input+    where input = compare (exists "x" (forall "y" (for_all "z" ((pApp "P" [var "y"] .=>. pApp "Q" [var "z"]) .=>. pApp "P" [var "x"] .=>. pApp "Q" [var "x"]))))++let p20 = compare+ <<(forall x y. exists z. forall w. P[var "x"] .&. Q[var "y"] .=>. R[var "z"] .&. U[var "w"])+   .=>. (exists x y. P[var "x"] .&. Q[var "y"]) .=>. (exists z. R[var "z"])>>;;++let p24 = compare+ <<~(exists x. U[var "x"] .&. Q[var "x"]) .&.+   (forall x. P[var "x"] .=>. Q[var "x"] .|. R[var "x"]) .&.+   ~(exists x. P[var "x"] .=>. (exists x. Q[var "x"])) .&.+   (forall x. Q[var "x"] .&. R[var "x"] .=>. U[var "x"])+   .=>. (exists x. P[var "x"] .&. R[var "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[var "x"] .=>. (exists y. G[var "y"] .&. H(x,y)) .&.+   (exists y. G[var "y"] .&. ~H(x,y))) .&.+   (exists x. J[var "x"] .&. (forall y. G[var "y"] .=>. H(x,y)))+   .=>. (exists x. J[var "x"] .&. ~P[var "x"])>>;;++let p59 = compare+ <<(forall x. P[var "x"] .<=>. ~P(f[var "x"])) .=>. (exists x. P[var "x"] .&. ~P(f[var "x"]))>>;;++let p60 = compare+ <<forall x. P(x,f[var "x"]) .<=>.+             exists y. (forall z. P(z,y) .=>. P(z,f[var "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 = Var("_" ++ 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) (undefined,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[var "a"] .&. (P[var "x"] .=>. (exists y. P[var "y"] .&. R(x,y))) .=>.+     (exists z w. P[var "z"] .&. R(x,w) .&. R(w,z))) .<=>.+   (forall x.+     (~P[var "a"] .|. P[var "x"] .|. (exists z w. P[var "z"] .&. R(x,w) .&. R(w,z))) .&.+     (~P[var "a"] .|. ~(exists y. P[var "y"] .&. R(x,y)) .|.+     (exists z w. P[var "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[var "x"] .<=>. P[var "y"]) .<=>.+    ((exists x. Q[var "x"]) .<=>. (forall y. Q[var "y"]))) .<=>.+   ((exists x. forall y. Q[var "x"] .<=>. Q[var "y"]) .<=>.+    ((exists x. P[var "x"]) .<=>. (forall y. P[var "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[var "x"] <= y .<=>. x <= g[var "y"])+   .=>. (forall x y. x <= y .=>. f[var "x"] <= f[var "y"]) .&.+       (forall x y. x <= y .=>. g[var "x"] <= g[var "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[var "y"] .=>. P[var "x"]>>;;++let p19 = time splittab+ <<exists x. forall y z. (P[var "y"] .=>. Q[var "z"]) .=>. P[var "x"] .=>. Q[var "x"]>>;;++let p20 = time splittab+ <<(forall x y. exists z. forall w. P[var "x"] .&. Q[var "y"] .=>. R[var "z"] .&. U[var "w"])+   .=>. (exists x y. P[var "x"] .&. Q[var "y"]) .=>. (exists z. R[var "z"])>>;;++let p21 = time splittab+ <<(exists x. P .=>. Q[var "x"]) .&. (exists x. Q[var "x"] .=>. P)+   .=>. (exists x. P .<=>. Q[var "x"])>>;;++let p22 = time splittab+ <<(forall x. P .<=>. Q[var "x"]) .=>. (P .<=>. (forall x. Q[var "x"]))>>;;++let p23 = time splittab+ <<(forall x. P .|. Q[var "x"]) .<=>. P .|. (forall x. Q[var "x"])>>;;++let p24 = time splittab+ <<~(exists x. U[var "x"] .&. Q[var "x"]) .&.+   (forall x. P[var "x"] .=>. Q[var "x"] .|. R[var "x"]) .&.+   ~(exists x. P[var "x"] .=>. (exists x. Q[var "x"])) .&.+   (forall x. Q[var "x"] .&. R[var "x"] .=>. U[var "x"]) .=>.+   (exists x. P[var "x"] .&. R[var "x"])>>;;++let p25 = time splittab+ <<(exists x. P[var "x"]) .&.+   (forall x. U[var "x"] .=>. ~G[var "x"] .&. R[var "x"]) .&.+   (forall x. P[var "x"] .=>. G[var "x"] .&. U[var "x"]) .&.+   ((forall x. P[var "x"] .=>. Q[var "x"]) .|. (exists x. Q[var "x"] .&. P[var "x"]))+   .=>. (exists x. Q[var "x"] .&. P[var "x"])>>;;++let p26 = time splittab+ <<((exists x. P[var "x"]) .<=>. (exists x. Q[var "x"])) .&.+   (forall x y. P[var "x"] .&. Q[var "y"] .=>. (R[var "x"] .<=>. U[var "y"]))+   .=>. ((forall x. P[var "x"] .=>. R[var "x"]) .<=>. (forall x. Q[var "x"] .=>. U[var "x"]))>>;;++let p27 = time splittab+ <<(exists x. P[var "x"] .&. ~Q[var "x"]) .&.+   (forall x. P[var "x"] .=>. R[var "x"]) .&.+   (forall x. U[var "x"] .&. V[var "x"] .=>. P[var "x"]) .&.+   (exists x. R[var "x"] .&. ~Q[var "x"])+   .=>. (forall x. U[var "x"] .=>. ~R[var "x"])+       .=>. (forall x. U[var "x"] .=>. ~V[var "x"])>>;;++let p28 = time splittab+ <<(forall x. P[var "x"] .=>. (forall x. Q[var "x"])) .&.+   ((forall x. Q[var "x"] .|. R[var "x"]) .=>. (exists x. Q[var "x"] .&. R[var "x"])) .&.+   ((exists x. R[var "x"]) .=>. (forall x. L[var "x"] .=>. M[var "x"])) .=>.+   (forall x. P[var "x"] .&. L[var "x"] .=>. M[var "x"])>>;;++let p29 = time splittab+ <<(exists x. P[var "x"]) .&. (exists x. G[var "x"]) .=>.+   ((forall x. P[var "x"] .=>. H[var "x"]) .&. (forall x. G[var "x"] .=>. J[var "x"]) .<=>.+    (forall x y. P[var "x"] .&. G[var "y"] .=>. H[var "x"] .&. J[var "y"]))>>;;++let p30 = time splittab+ <<(forall x. P[var "x"] .|. G[var "x"] .=>. ~H[var "x"]) .&.+   (forall x. (G[var "x"] .=>. ~U[var "x"]) .=>. P[var "x"] .&. H[var "x"])+   .=>. (forall x. U[var "x"])>>;;++let p31 = time splittab+ <<~(exists x. P[var "x"] .&. (G[var "x"] .|. H[var "x"])) .&.+   (exists x. Q[var "x"] .&. P[var "x"]) .&.+   (forall x. ~H[var "x"] .=>. J[var "x"])+   .=>. (exists x. Q[var "x"] .&. J[var "x"])>>;;++let p32 = time splittab+ <<(forall x. P[var "x"] .&. (G[var "x"] .|. H[var "x"]) .=>. Q[var "x"]) .&.+   (forall x. Q[var "x"] .&. H[var "x"] .=>. J[var "x"]) .&.+   (forall x. R[var "x"] .=>. H[var "x"])+   .=>. (forall x. P[var "x"] .&. R[var "x"] .=>. J[var "x"])>>;;++let p33 = time splittab+ <<(forall x. P[var "a"] .&. (P[var "x"] .=>. P[var "b"]) .=>. P[var "c"]) .<=>.+   (forall x. P[var "a"] .=>. P[var "x"] .|. P[var "c"]) .&. (P[var "a"] .=>. P[var "b"] .=>. P[var "c"])>>;;++let p34 = time splittab+ <<((exists x. forall y. P[var "x"] .<=>. P[var "y"]) .<=>.+    ((exists x. Q[var "x"]) .<=>. (forall y. Q[var "y"]))) .<=>.+   ((exists x. forall y. Q[var "x"] .<=>. Q[var "y"]) .<=>.+    ((exists x. P[var "x"]) .<=>. (forall y. P[var "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[var "a"] .&. (P[var "x"] .=>. (exists y. P[var "y"] .&. R(x,y))) .=>.+     (exists z w. P[var "z"] .&. R(x,w) .&. R(w,z))) .<=>.+   (forall x.+     (~P[var "a"] .|. P[var "x"] .|. (exists z w. P[var "z"] .&. R(x,w) .&. R(w,z))) .&.+     (~P[var "a"] .|. ~(exists y. P[var "y"] .&. R(x,y)) .|.+     (exists z w. P[var "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[var "x"] .=>. (exists y. G[var "y"] .&. H(x,y)) .&.+   (exists y. G[var "y"] .&. ~H(x,y))) .&.+   (exists x. J[var "x"] .&. (forall y. G[var "y"] .=>. H(x,y))) .=>.+   (exists x. J[var "x"] .&. ~P[var "x"])>>;;++let p45 = time splittab+ <<(forall x.+     P[var "x"] .&. (forall y. G[var "y"] .&. H(x,y) .=>. J(x,y)) .=>.+       (forall y. G[var "y"] .&. H(x,y) .=>. R[var "y"])) .&.+   ~(exists y. L[var "y"] .&. R[var "y"]) .&.+   (exists x. P[var "x"] .&. (forall y. H(x,y) .=>.+     L[var "y"]) .&. (forall y. G[var "y"] .&. H(x,y) .=>. J(x,y))) .=>.+   (exists x. P[var "x"] .&. ~(exists y. G[var "y"] .&. H(x,y)))>>;;++let p46 = time splittab+ <<(forall x. P[var "x"] .&. (forall y. P[var "y"] .&. H(y,x) .=>. G[var "y"]) .=>. G[var "x"]) .&.+   ((exists x. P[var "x"] .&. ~G[var "x"]) .=>.+    (exists x. P[var "x"] .&. ~G[var "x"] .&.+               (forall y. P[var "y"] .&. ~G[var "y"] .=>. J(x,y)))) .&.+   (forall x y. P[var "x"] .&. P[var "y"] .&. H(x,y) .=>. ~J(y,x)) .=>.+   (forall x. P[var "x"] .=>. G[var "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[var "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([var "a"],b),f(b,c)) .&.+   P(f(b,c),f(a,c)) .&.+   (forall [var "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[var "x"] .&. Q[var "y"]) .=>. ((P[var "v"] .|. R[var "w"])  .&. (R[var "z"] .=>. Q[var "v"])))>>;;++let p59 = time splittab+ <<(forall x. P[var "x"] .<=>. ~P(f[var "x"])) .=>. (exists x. P[var "x"] .&. ~P(f[var "x"]))>>;;++let p60 = time splittab+ <<forall x. P(x,f[var "x"]) .<=>.+            exists y. (forall z. P(z,y) .=>. P(z,f[var "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[var "y"] .=>. G[var "y"]) .<=>. F[var "x"]) .&.+      ((F[var "y"] .=>. H[var "y"]) .<=>. G[var "x"]) .&.+      (((F[var "y"] .=>. G[var "y"]) .=>. H[var "y"]) .<=>. H[var "x"])+      .=>. F[var "z"] .&. G[var "z"] .&. H[var "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[var "y"] .=>. H[var "x"])) .=>. F(x,x)) .&.+        ((F(z,x) .=>. G[var "x"]) .=>. H[var "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[var "x"] .=>. exists y. L[var "y"] .&. (F(x,y) .=>. G(x,y))) .&.+   (exists z. K[var "z"] .&. forall u. L[var "u"] .=>. F(z,u))+   .=>. exists v w. K[var "v"] .&. L[var "w"] .&. G(v,w)>>;;++let gilmore_8 = time splittab+ <<exists x. forall y z.+        ((F(y,z) .=>. (G[var "y"] .=>. (forall u. exists v. H(u,v,x)))) .=>. F(x,x)) .&.+        ((F(z,x) .=>. G[var "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 view
@@ -0,0 +1,124 @@+{-# OPTIONS -Wall #-}+module Data.Logic.Harrison.Unif+    ( unify+    , solve+    , fullUnify+    , unifyAndApply+    ) where++import Control.Applicative.Error (Failing(..), failing)+import Data.Logic.Classes.Term (Term(..), tsubst)+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,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,              RankNTypes, TypeSynonymInstances, UndecidableInstances #-}-{-# OPTIONS -Wall -Werror -fno-warn-orphans -fno-warn-missing-signatures #-}+{-# OPTIONS -Wall -Wwarn -fno-warn-orphans -fno-warn-missing-signatures #-} module Data.Logic.Instances.Chiou     ( Sentence(..)     , CTerm(..)@@ -14,15 +14,17 @@     ) where  import Data.Generics (Data, Typeable)+import Data.Logic.Classes.Apply (Apply(..)) import Data.Logic.Classes.Arity (Arity)-import Data.Logic.Classes.Boolean (Boolean(..))-import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), Quant(..), quant')-import Data.Logic.Classes.Logic (Logic(..))-import Data.Logic.Classes.Negatable (Negatable(..))-import Data.Logic.Classes.Pred (Pred(..), pApp)-import Data.Logic.Classes.Term as Logic+import Data.Logic.Classes.Combine (Combinable(..), BinOp(..), Combination(..))+import Data.Logic.Classes.Constants (Constants(..), asBool)+import Data.Logic.Classes.Equals (AtomEq(..), (.=.))+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), Quant(..), quant', pApp)+import Data.Logic.Classes.Formula (Formula)+import Data.Logic.Classes.Negate (Negatable(..), (.~.))+import Data.Logic.Classes.Term (Term(..)) import qualified Data.Logic.Classes.FirstOrder as L-import Data.Logic.Classes.Propositional (PropositionalFormula(..), BinOp(..), Combine(..))+import Data.Logic.Classes.Propositional (PropositionalFormula(..)) import Data.Logic.Classes.Skolem (Skolem(..)) import Data.Logic.Classes.Variable (Variable) import Data.String (IsString(..))@@ -53,38 +55,39 @@     deriving (Eq, Ord, Show, Data, Typeable)  instance Negatable (Sentence v p f) where-    (.~.) (Not (Not x)) = (.~.) x-    (.~.) (Not x) = x-    (.~.) x   = Not x-    negated (Not x) = not (negated x)-    negated _ = False+    negatePrivate = Not+    foldNegation normal inverted (Not x) = foldNegation inverted normal x+    foldNegation normal _ x = normal x -instance (Ord v, Ord p, Ord f) => Logic (Sentence v p f) where+instance Constants p => Constants (Sentence v p f) where+    fromBool x = Predicate (fromBool x) []++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 (Ord v, IsString v, Data v, Variable v, -          Ord p, IsString p, Data p, Boolean p, Arity p,-          Ord f, IsString f, Data f, Skolem f, -          Boolean (Sentence v p f), Logic (Sentence v p f)) =>+          Ord p, IsString p, Data p, Constants p, Arity p,+          Ord f, IsString f, Data f, Skolem f,+          {- Constants (Sentence v p f), -} Combinable (Sentence v p f)) =>          PropositionalFormula (Sentence v p f) (Sentence v p f) where     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 (Predicate p ts) = pApp p ts-    atomic (Equal t1 t2) = t1 .=. t2-    foldPropositional c a formula =+    atomic x@(Predicate _ _) = x+    atomic x@(Equal _ _) = x+    foldPropositional co tf at formula =         case formula of-          Not x -> c ((:~:) x)+          Not x -> co ((:~:) x)           Quantifier _ _ _ -> error "Logic.Instance.Chiou.foldF0: unexpected"-          Connective f1 Imply f2 -> c (BinOp f1 (:=>:) f2)-          Connective f1 Equiv f2 -> c (BinOp f1 (:<=>:) f2)-          Connective f1 And f2 -> c (BinOp f1 (:&:) f2)-          Connective f1 Or f2 -> c (BinOp f1 (:|:) f2)-          Predicate p ts -> a (Predicate p ts)-          Equal t1 t2 -> a (Equal t1 t2)+          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)+          Equal t1 t2 -> at (Equal t1 t2)  data AtomicFunction     = AtomicFunction String@@ -101,78 +104,83 @@     fromSkolem (AtomicSkolemFunction n) = Just n     fromSkolem _ = Nothing -instance (Ord v, Ord p, Arity p, Boolean p, Ord f) => Pred p (CTerm v f) (Sentence v p f) where-    pApp0 x = Predicate x []-    pApp1 x a = Predicate x [a]-    pApp2 x a b = Predicate x [a,b]-    pApp3 x a b c = Predicate x [a,b,c]-    pApp4 x a b c d = Predicate x [a,b,c,d]-    pApp5 x a b c d e = Predicate x [a,b,c,d,e]-    pApp6 x a b c d e f = Predicate x [a,b,c,d,e,f]-    pApp7 x a b c d e f g = Predicate x [a,b,c,d,e,f,g]-    -- fApp (AtomicSkolemFunction n) [] = SkolemConstant n-    -- fApp (AtomicSkolemFunction n) ts = SkolemFunction n ts-    x .=. y = Equal x y+-- The Atom type is not cleanly distinguished from the Sentence type, so we need an Atom instance for Sentence.+instance ({- Constants (Sentence v p f), -} Ord v, Ord p, Arity p, Constants p, Ord f) => 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 (Arity p, Show p, Constants p, Eq 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 (Ord v, IsString v, Variable v, Data v, Show v,-          Ord p, IsString p, Boolean p, Arity p, Data p, Show p,+          Ord p, IsString p, Constants p, Arity p, Data p, Show p,           Ord f, IsString f, Skolem f, Data f, Show f,           PropositionalFormula (Sentence v p f) (Sentence v p f)) =>-          FirstOrderFormula (Sentence v p f) (CTerm v f) v p f where+          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 q c p f =+    foldFirstOrder qu co tf at f =         case f of-          Not x -> c ((:~:) x)+          Not x -> co ((:~:) x)           Quantifier op (v:vs) f' ->               let op' = case op of-                          ForAll -> All+                          ForAll -> Forall                           ExistsCh -> Exists in               -- Use Logic.quant' here instead of the constructor               -- Quantifier so as not to create quantifications with               -- empty variable lists.-              q op' v (quant' op' vs f')-          Quantifier _ [] f' -> foldFirstOrder q c p f'-          Connective f1 Imply f2 -> c (BinOp f1 (:=>:) f2)-          Connective f1 Equiv f2 -> c (BinOp f1 (:<=>:) f2)-          Connective f1 And f2 -> c (BinOp f1 (:&:) f2)-          Connective f1 Or f2 -> c (BinOp f1 (:|:) f2)-          Predicate name ts -> p (L.Apply name ts)-          Equal t1 t2 -> p (L.Equal t1 t2)-    zipFirstOrder q c p f1 f2 =+              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)+          Predicate _ _ -> at f+          Equal _ _ -> at f+{-+    zipFirstOrder qu co tf at f1 f2 =         case (f1, f2) of-          (Not f1', Not f2') -> c ((:~:) f1') ((:~:) f2')+          (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 -> All+                               ForAll -> Forall                                ExistsCh -> Exists in-                   q op' v1 (Quantifier op1 vs1 f1') All v2 (Quantifier op2 vs2 f2')+                   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 q c p f1' f2' else Nothing+              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) -> c (BinOp l1 (:&:) r1) (BinOp l2 (:&:) r2)-                (Or, Or) -> c (BinOp l1 (:|:) r1) (BinOp l2 (:|:) r2)-                (Imply, Imply) -> c (BinOp l1 (:=>:) r1) (BinOp l2 (:=>:) r2)-                (Equiv, Equiv) -> c (BinOp l1 (:<=>:) r1) (BinOp l2 (:<=>:) r2)+                (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 l1 r1, Equal l2 r2) -> p (L.Equal l1 r1) (L.Equal l2 r2)-          (Predicate p1 ts1, Predicate p2 ts2) -> p (L.Apply p1 ts1) (L.Apply p2 ts2)+          (Equal _ _, Equal _ _) -> at f1 f2+          (Predicate _ _, Predicate _ _) -> at f1 f2           _ -> Nothing+-}+    atomic x@(Predicate _ _) = x+    atomic x@(Equal _ _) = x+    atomic _ = error "Chiou: atomic" -instance (Ord v, Variable v, Data v, Eq f, Ord f, Skolem f, Data f) => Logic.Term (CTerm v f) v f where+instance (Ord v, Variable v, Data v, Eq f, Ord f, Skolem f, Data f) => Term (CTerm v f) v f where     foldTerm v fn t =         case t of           Variable x -> v x           Function f ts -> fn f ts-    zipT  v f t1 t2 =+    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-    var = Variable+    vt = Variable     fApp f ts = Function f ts  data ConjunctiveNormalForm v p f =@@ -192,14 +200,16 @@     | NormalVariable v     deriving (Eq, Ord, Data, Typeable) +instance Constants p => Constants (NormalSentence v p f) where+    fromBool x = NFPredicate (fromBool x) []+ instance Negatable (NormalSentence v p f) where-    (.~.) (NFNot (NFNot x)) = ((.~.) x)-    (.~.) (NFNot x)= x-    (.~.) x   = NFNot x-    negated (NFNot x) = not (negated x)-    negated _ = False+    negatePrivate = NFNot+    foldNegation normal inverted (NFNot x) = foldNegation inverted normal x+    foldNegation normal _ x = normal x -instance (Arity p, Boolean p, Logic (NormalSentence v p f)) => Pred p (NormalTerm v f) (NormalSentence v p f) where+{-+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]@@ -210,48 +220,55 @@     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 (Logic (NormalSentence v p f), Logic.Term (NormalTerm v f) v f,+instance (Combinable (NormalSentence v p f), Term (NormalTerm v f) v f,           IsString v, Show v,-          Ord p, IsString p, Boolean p, Arity p, Data p, Show p,-          Ord f, IsString f, Show f) => FirstOrderFormula (NormalSentence v p f) (NormalTerm v f) v p f where+          Ord p, IsString p, Constants p, Arity p, Data p, Show p,+          Ord f, IsString f, Show f) => FirstOrderFormula (NormalSentence v p f) (NormalSentence v p f) v where     for_all _ _ = error "FirstOrderFormula NormalSentence"     exists _ _ = error "FirstOrderFormula NormalSentence"-    foldFirstOrder _ c p f =+    foldFirstOrder _ co tf at f =         case f of-          NFNot x -> c ((:~:) x)-          NFEqual t1 t2 -> p (L.Equal t1 t2)-          NFPredicate pr ts -> p (L.Apply pr ts)-    zipFirstOrder _ c p f1 f2 =+          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') -> c ((:~:) f1') ((:~:) f2')-          (NFEqual f1l f1r, NFEqual f2l f2r) -> p (L.Equal f1l f1r) (L.Equal f2l f2r)-          (NFPredicate p1 ts1, NFPredicate p2 ts2) -> p (L.Apply p1 ts1) (L.Apply p2 ts2)+          (NFNot f1', NFNot f2') -> co ((:~:) f1') ((:~:) f2')+          (NFEqual _ _, NFEqual _ _) -> at f1 f2+          (NFPredicate _ _, NFPredicate _ _) -> at f1 f2           _ -> Nothing+-}+    atomic x@(NFPredicate _ _) = x+    atomic x@(NFEqual _ _) = x+    atomic _ = error "Chiou: atomic" -instance (Ord v, Variable v, Data v, Eq f, Ord f, Skolem f, Data f) => Logic.Term (NormalTerm v f) v f where-    var = NormalVariable+instance (Ord v, Variable v, Data v, Eq f, Ord f, Skolem f, Data f) => Term (NormalTerm v f) v f where+    vt = NormalVariable     fApp = NormalFunction     foldTerm v f t =             case t of               NormalVariable x -> v x               NormalFunction x ts -> f x ts-    zipT v fn t1 t2 =+    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) (CTerm v f) v p f => NormalSentence v p f -> Sentence v p f+toSentence :: (FirstOrderFormula (Sentence v p f) (Sentence v p f) v, Formula (Sentence v p f) (CTerm v f) v, Skolem f, Ord f, Data f, Data v, Constants p, Ord p, Show p, Arity p) =>+              NormalSentence v p f -> Sentence v p f toSentence (NFNot s) = (.~.) (toSentence s) toSentence (NFEqual t1 t2) = toTerm t1 .=. toTerm t2 toSentence (NFPredicate p ts) = pApp p (map toTerm ts)  toTerm :: (Ord v, Variable v, Data v, Eq f, Ord f, Skolem f, Data f) => NormalTerm v f -> CTerm v f-toTerm (NormalFunction f ts) = Logic.fApp f (map toTerm ts)-toTerm (NormalVariable v) = Logic.var v+toTerm (NormalFunction f ts) = fApp f (map toTerm ts)+toTerm (NormalVariable v) = vt v -fromSentence :: forall v p f. FirstOrderFormula (Sentence v p f) (CTerm v f) v p f =>+fromSentence :: forall v p f. (FirstOrderFormula (Sentence v p f) (Sentence v p f) v, Arity p, Constants p, Ord p, Ord f, Show p) =>                 Sentence v p f -> NormalSentence v p f fromSentence = foldFirstOrder                   (\ _ _ _ -> error "fromSentence 1")@@ -259,13 +276,10 @@                       case cm of                         ((:~:) f) -> NFNot (fromSentence f)                         _ -> error "fromSentence 2")-                 (\ pa ->-                      case pa of-                        L.Equal t1 t2 -> NFEqual (fromTerm t1) (fromTerm t2)-                        L.NotEqual t1 t2 -> NFNot (NFEqual (fromTerm t1) (fromTerm t2))-                        L.Constant x -> NFPredicate (fromBool x) []-                        L.Apply p ts -> NFPredicate p (map fromTerm ts))-+                 (\ x -> NFPredicate (fromBool x) [])+                 (foldAtomEq (\ p ts -> NFPredicate p (map fromTerm ts))+                             (\ x -> NFPredicate (fromBool x) [])+                             (\ t1 t2 -> NFEqual (fromTerm t1) (fromTerm t2)))  fromTerm :: CTerm v f -> NormalTerm v f fromTerm (Function f ts) = NormalFunction f (map fromTerm ts)
Data/Logic/Instances/PropLogic.hs view
@@ -6,56 +6,56 @@     , plSat     ) where -import Data.Logic.Classes.Boolean (Boolean(fromBool))+import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..))+import Data.Logic.Classes.Constants (Constants(fromBool)) import Data.Logic.Classes.FirstOrder (FirstOrderFormula, toPropositional)-import Data.Logic.Classes.Negatable (Negatable(..))-import Data.Logic.Classes.Logic (Logic(..))-import Data.Logic.Classes.Propositional (PropositionalFormula(..), Combine(..), BinOp(..), clauseNormalForm')+import Data.Logic.Classes.Formula (Formula) import Data.Logic.Classes.Literal (Literal(..))+import Data.Logic.Classes.Negate (Negatable(..))+import Data.Logic.Classes.Propositional (PropositionalFormula(..), clauseNormalForm')+import Data.Logic.Classes.Term (Term)+import Data.Logic.Harrison.Skolem (SkolemT) import Data.Logic.Normal.Clause (clauseNormalForm)-import Data.Logic.Normal.Skolem (NormalT) import qualified Data.Set.Extra as S import PropLogic  instance Negatable (PropForm a) where-    (.~.) (N (N x)) = (.~.) x-    (.~.) (N x) = x-    (.~.) x = N x-    negated (N x) = not (negated x)-    negated _ = False+    negatePrivate = N+    foldNegation normal inverted (N x) = foldNegation inverted normal x+    foldNegation normal _ x = normal x -instance Ord a => Logic (PropForm a) where+instance Ord a => Combinable (PropForm a) where     x .<=>. y = EJ [x, y]     x .=>.  y = SJ [x, y]     x .|.   y = DJ [x, y]     x .&.   y = CJ [x, y] -instance (Logic (PropForm a), Ord a) => PropositionalFormula (PropForm a) a where+instance (Combinable (PropForm a), Ord a) => PropositionalFormula (PropForm a) a where     atomic = A-    foldPropositional c a formula =+    foldPropositional co tf at formula =         case formula of           -- EJ [x,y,z,...] -> CJ [EJ [x,y], EJ[y,z], ...]-          EJ [] -> error "Empty EJ"-          EJ [x] -> foldPropositional c a x-          EJ [x0, x1] -> c (BinOp x0 (:<=>:) x1)-          EJ xs -> foldPropositional c a (CJ (map (\ (x0, x1) -> EJ [x0, x1]) (pairs xs)))-          SJ [] -> error "Empty SJ"-          SJ [x] -> foldPropositional c a x-          SJ [x0, x1] -> c (BinOp x0 (:=>:) x1)-          SJ xs -> foldPropositional c a (CJ (map (\ (x0, x1) -> SJ [x0, x1]) (pairs xs)))-          DJ [] -> error "Empty disjunct"-          DJ [x] -> foldPropositional c a x-          DJ (x0:xs) -> c (BinOp x0 (:|:) (DJ xs))-          CJ [] -> error "Empty conjunct"-          CJ [x] -> foldPropositional c a x-          CJ (x0:xs) -> c (BinOp x0 (:&:) (CJ xs))-          N x -> c ((:~:) x)+          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)))+          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)))+          DJ [] -> tf False+          DJ [x] -> foldPropositional co tf at x+          DJ (x0:xs) -> co (BinOp 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.-          T -> error "foldPropositional method of PropForm: T"-          F -> error "foldPropositional method of PropForm: F"-          A x -> a x+          T -> tf True+          F -> tf False+          A x -> at x -instance Boolean (PropForm formula) where+instance Constants (PropForm formula) where     fromBool True = T     fromBool False = F @@ -79,16 +79,16 @@ flatten (N x) = N (flatten x) flatten x = x -plSat0 :: (PropAlg a (PropForm formula), PropositionalFormula formula atom) => PropForm formula -> Bool+plSat0 :: (PropAlg a (PropForm formula), PropositionalFormula formula atom, Ord formula) => PropForm formula -> Bool plSat0 f = satisfiable . (\ (x :: PropForm formula) -> x) . clauses0 $ f -clauses0 :: PropositionalFormula formula atom => PropForm formula -> PropForm formula+clauses0 :: (PropositionalFormula formula atom, Ord formula) => PropForm formula -> PropForm formula clauses0 f = CJ . map DJ . map S.toList . S.toList $ clauseNormalForm' f -plSat :: forall m formula term v p f. (Monad m, FirstOrderFormula formula term v p f, Ord formula, Literal formula term v p f) =>-                formula -> NormalT v term m Bool+plSat :: forall m formula atom term v f. (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f, Ord formula, Literal formula atom v) =>+                formula -> SkolemT v term m Bool plSat f = clauses f >>= (\ (x :: PropForm formula) -> return x) >>= return . satisfiable -clauses :: forall m formula term v p f. (Monad m, FirstOrderFormula formula term v p f, Literal formula term v p f) =>-           formula -> NormalT v term m (PropForm formula)+clauses :: forall m formula atom term v f. (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f, Literal formula atom v, Ord formula) =>+           formula -> SkolemT v term m (PropForm formula) clauses f = clauseNormalForm f >>= return . CJ . map (DJ . map (toPropositional (A :: formula -> PropForm formula))) . map S.toList . S.toList
Data/Logic/Instances/SatSolver.hs view
@@ -7,12 +7,16 @@ import Data.Boolean.SatSolver import Data.Generics (Data, Typeable) import qualified Data.Set.Extra as S-import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..)) import Data.Logic.Classes.ClauseNormalForm (ClauseNormalFormula(..))+import Data.Logic.Classes.Constants (Constants)+import Data.Logic.Classes.Equals (AtomEq)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..))+import Data.Logic.Classes.Formula (Formula) import qualified Data.Logic.Classes.Literal as N-import Data.Logic.Classes.Negatable (Negatable(..))+import Data.Logic.Classes.Negate (Negatable(..), negated, (.~.))+import Data.Logic.Classes.Term (Term) import Data.Logic.Normal.Clause (clauseNormalForm)-import Data.Logic.Normal.Skolem (LiteralMapT, NormalT')+import Data.Logic.Normal.Implicative (LiteralMapT, NormalT) import qualified Data.Map as M  instance Ord Literal where@@ -22,10 +26,10 @@     compare (Neg m) (Neg n) = compare m n  instance Negatable Literal where-    (.~.) (Pos n) = Neg n-    (.~.) (Neg n) = Pos n-    negated (Pos _) = False-    negated (Neg _) = True+    negatePrivate (Neg x) = Pos x+    negatePrivate (Pos x) = Neg x+    foldNegation _ inverted (Neg x) = inverted (Pos x)+    foldNegation normal _ (Pos x) = normal (Pos x)  deriving instance Data Literal deriving instance Typeable Literal@@ -35,8 +39,8 @@     makeCNF = map S.toList . S.toList     satisfiable cnf = return . not . null $ assertTrue' cnf newSatSolver >>= solve -toCNF :: (Monad m, FirstOrderFormula formula term v p f, N.Literal formula term v p f) =>-         formula -> NormalT' formula v term m CNF+toCNF :: (Monad m, FirstOrderFormula formula atom v, Formula atom term v, AtomEq atom p term, Term term v f, N.Literal formula atom v, Ord formula, Constants p, Eq p) =>+         formula -> NormalT formula v term m CNF toCNF f = clauseNormalForm f >>= S.ssMapM (lift . toLiteral) >>= return . makeCNF  -- |Convert a [[formula]] to CNF, which means building a map from
Data/Logic/KnowledgeBase.hs view
@@ -28,11 +28,15 @@ import "mtl" Control.Monad.State (StateT, evalStateT, MonadState(get, put)) import "mtl" Control.Monad.Trans (lift) import Data.Generics (Data, Typeable)+import Data.Logic.Classes.Constants (Constants)+import Data.Logic.Classes.Equals (AtomEq) import Data.Logic.Classes.FirstOrder (FirstOrderFormula)-import Data.Logic.Classes.Negatable (Negatable(..))+import Data.Logic.Classes.Formula (Formula)+import Data.Logic.Classes.Negate ((.~.)) import Data.Logic.Classes.Literal (Literal)+import Data.Logic.Classes.Term (Term)+import Data.Logic.Harrison.Skolem (SkolemT, runSkolemT) import Data.Logic.Normal.Implicative (ImplicativeForm, implicativeNormalForm)-import Data.Logic.Normal.Skolem (NormalT, runNormalT) import Data.Logic.Resolution (prove, SetOfSupport, getSetOfSupport) import Data.SafeCopy (deriveSafeCopy, base) import qualified Data.Set.Extra as S@@ -77,10 +81,10 @@  -- |A monad for running the knowledge base. type ProverT inf = StateT (ProverState inf)-type ProverT' v term inf m a = ProverT inf (NormalT v term m) a+type ProverT' v term inf m a = ProverT inf (SkolemT v term m) a  runProverT' :: Monad m => Maybe Int -> ProverT' v term inf m a -> m a-runProverT' limit = runNormalT . runProverT limit+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@@ -108,7 +112,7 @@  data Proof lit = Proof {proofResult :: ProofResult, proof :: S.Set (ImplicativeForm lit)} deriving (Data, Typeable, Eq, Ord) -instance (Ord lit, Show lit, Literal lit term v p f, FirstOrderFormula lit term v p f) => Show (Proof lit) where+instance (Ord lit, Show lit, Literal lit atom v, FirstOrderFormula lit atom v) => Show (Proof lit) where     show p = "Proof {proofResult = " ++ show (proofResult p) ++ ", proof = " ++ show (proof p) ++ "}"  -- |Remove a particular sentence from the knowledge base@@ -124,7 +128,9 @@  -- |Return a flag indicating whether sentence was disproved, along -- with a disproof.-inconsistantKB :: forall m formula term v p f lit. (FirstOrderFormula formula term v p f, Literal lit term v p f, Monad m, Show term) =>+inconsistantKB :: forall m formula atom term v p f lit.+                  (FirstOrderFormula formula atom v, Literal lit atom v, Formula atom term v, AtomEq atom p term, Term term v f,+                   Monad m, Show term, Eq formula, Data formula, Data lit, Eq lit, Ord lit, Ord term, Constants p, Eq p) =>                   formula -> ProverT' v term (ImplicativeForm lit) m (Bool, SetOfSupport lit v term) inconsistantKB s =     get >>= \ st ->@@ -135,20 +141,24 @@  -- |Return a flag indicating whether sentence was proved, along with a -- proof.-theoremKB :: forall m formula term v p f lit. (Monad m, FirstOrderFormula formula term v p f, Literal lit term v p f, Show term) =>+theoremKB :: forall m formula atom term v p f lit.+             (Monad m, FirstOrderFormula formula atom v, Literal lit atom v, Formula atom term v, AtomEq atom p term, Term term v f,+              Show term, Eq formula, Ord term, Ord lit, Data formula, Data lit, Constants p, Eq p) =>              formula -> ProverT' v term (ImplicativeForm 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 term v p f, Literal lit term v p f, Show term) =>+askKB :: (Monad m, FirstOrderFormula formula atom v, Literal lit atom v, Formula atom term v, AtomEq atom p term, Term term v f,+          Eq formula, Show term, Ord term, Ord lit, Data formula, Data lit, Constants p, Eq p) =>          formula -> ProverT' v term (ImplicativeForm 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 term v p f, Literal lit term v p f, Monad m, Show term) =>+validKB :: (FirstOrderFormula formula atom v, Literal lit atom v, Formula atom term v, AtomEq atom p term, Term term v f,+            Monad m, Eq formula, Show term, Ord term, Ord lit, Data formula, Data lit, Constants p, Eq p) =>            formula -> ProverT' v term (ImplicativeForm lit) m (ProofResult, SetOfSupport lit v term, SetOfSupport lit v term) validKB s =     theoremKB s >>= \ (proved, proof1) ->@@ -158,7 +168,8 @@ -- |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 term v p f, Literal lit term v p f, Monad m, Show term) =>+tellKB :: (FirstOrderFormula formula atom v, Literal lit atom v, Formula atom term v, AtomEq atom p term, Term term v f,+           Monad m, Show term, Eq formula, Data formula, Data lit, Eq lit, Ord lit, Ord term, Constants p, Eq p) =>           formula -> ProverT' v term (ImplicativeForm lit) m (Proof lit) tellKB s =     do st <- get@@ -171,7 +182,8 @@                      , sentenceCount = sentenceCount st + 1 }        return $ Proof {proofResult = valid, proof = S.map wiItem inf'} -loadKB :: (FirstOrderFormula formula term v p f, Literal lit term v p f, Monad m, Show term) =>+loadKB :: (FirstOrderFormula formula atom v, Literal lit atom v, Formula atom term v, AtomEq atom p term, Term term v f,+           Monad m, Eq formula, Show term, Ord term, Ord lit, Data formula, Data lit, Constants p, Eq p) =>           [formula] -> ProverT' v term (ImplicativeForm lit) m [Proof lit] loadKB sentences = mapM tellKB sentences
Data/Logic/Normal/Clause.hs view
@@ -29,20 +29,19 @@ {-# OPTIONS -Wall #-} module Data.Logic.Normal.Clause     ( clauseNormalForm-    , trivial     , cnfTrace     ) where -import Data.Logic.Normal.Negation (negationNormalForm, nnf, simplify)-import Data.Logic.Normal.Prenex (prenexNormalForm)-import Data.Logic.Normal.Skolem (skolemNormalForm, NormalT)- import Data.List (intersperse)-import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), prettyFirstOrder, Predicate(..))-import Data.Logic.Classes.Propositional (Combine(..), BinOp(..))-import Data.Logic.Classes.Boolean (Boolean(..))-import Data.Logic.Classes.Negatable (Negatable(..))-import Data.Logic.Classes.Literal (Literal(..), prettyLit, fromFirstOrder)+import Data.Logic.Classes.Constants (Constants(..))+import Data.Logic.Classes.Equals (AtomEq, prettyAtomEq)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), prettyFirstOrder)+import Data.Logic.Classes.Formula (Formula)+import Data.Logic.Classes.Literal (Literal(..), prettyLit)+import Data.Logic.Classes.Term (Term)+import Data.Logic.Harrison.Normal (simpcnf')+import Data.Logic.Harrison.Skolem (skolemNormalForm, SkolemT, pnf, nnf, simplify)+import qualified Data.Map as Map import qualified Data.Set.Extra as Set import Text.PrettyPrint (Doc, hcat, vcat, text, nest, ($$), brackets, render) @@ -54,70 +53,28 @@ -- (Q & R) | P  (Q | P) & (R | P) -- @ -- -clauseNormalForm :: (Monad m, FirstOrderFormula formula term v p f, Literal lit term v p f) =>-       formula -> NormalT v term m (Set.Set (Set.Set lit))-clauseNormalForm fm = skolemNormalForm fm >>= return . simpcnf+clauseNormalForm :: (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f, Literal lit atom v, Eq formula, Ord lit) =>+                    formula -> SkolemT v term m (Set.Set (Set.Set lit))+clauseNormalForm fm = skolemNormalForm fm >>= return . simpcnf' -cnfTrace :: forall m formula term v p f lit.-            (Monad m, FirstOrderFormula formula term v p f, Literal lit term v p f) =>+cnfTrace :: forall m formula atom term v p f lit.+            (Monad m, FirstOrderFormula formula atom v, Formula atom term v, AtomEq atom p term, Term term v f, Literal lit atom v, Eq formula, Ord lit, Constants p, Eq p) =>             (v -> Doc)          -> (p -> Doc)          -> (f -> Doc)          -> formula-         -> NormalT v term m (String, Set.Set (Set.Set lit))+         -> SkolemT v term m (String, Set.Set (Set.Set lit)) cnfTrace pv pp pf f =-    do let simplified = simplify f-           pnf = prenexNormalForm f-       snf <- skolemNormalForm f+    do snf <- skolemNormalForm f        cnf <- clauseNormalForm f        return (render (vcat-                       [text "Original:" $$ nest 2 (prettyFirstOrder pv pp pf 0 f),-                        text "Simplified:" $$ nest 2 (prettyFirstOrder pv pp pf 0 simplified),-                        text "Negation Normal Form:" $$ nest 2 (prettyFirstOrder pv pp pf 0 (negationNormalForm f)),-                        text "Prenex Normal Form:" $$ nest 2 (prettyFirstOrder pv pp pf 0 pnf),-                        text "Skolem Normal Form:" $$ nest 2 (prettyFirstOrder pv pp pf 0 snf),+                       [text "Original:" $$ nest 2 (prettyFirstOrder (prettyAtomEq pv pp pf) pv 0 f),+                        text "Simplified:" $$ nest 2 (prettyFirstOrder (prettyAtomEq pv pp pf) pv 0 (simplify f)),+                        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)     where       prettyClause (clause :: [lit]) =-          nest 2 . brackets . hcat . intersperse (text ", ") . map (nest 2 . brackets . prettyLit pv pp pf 0) $ clause+          nest 2 . brackets . hcat . intersperse (text ", ") . map (nest 2 . brackets . prettyLit (prettyAtomEq pv pp pf) pv 0) $ clause       fromSS = (map Set.toList) . Set.toList --simpcnf :: forall formula term v p f lit. (FirstOrderFormula formula term v p f, Literal lit term v p f) =>-           formula -> Set.Set (Set.Set lit)-simpcnf fm =-    foldFirstOrder (\ _ _ _ -> cjs') (\ _ -> cjs') p fm-    where-      p (Apply pr _ts)-          | pr == fromBool False = Set.empty-          | pr == fromBool True = Set.singleton Set.empty-          | True = cjs'-      p (Equal _ _) = cjs'-      p (NotEqual _ _) = cjs'-      p (Constant _) = cjs'-      -- 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)---- |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---- | CNF: (a | b | c) & (d | e | f)-purecnf :: forall formula term v p f lit. (FirstOrderFormula formula term v p f, Literal lit term v p f) =>-           formula -> Set.Set (Set.Set lit)-purecnf fm = Set.map (Set.map (.~.)) (purednf (nnf ((.~.) fm)))--purednf :: forall formula term v p f lit. (FirstOrderFormula formula term v p f, Literal lit term v p f) =>-           formula -> Set.Set (Set.Set lit)-purednf fm =-    foldFirstOrder (\ _ _ _ -> x) c (\ _ -> x)  fm-    where-      c :: Combine formula -> Set.Set (Set.Set lit)-      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 lit)-      x = Set.singleton (Set.singleton (fromFirstOrder id id id fm)) :: Set.Set (Set.Set lit)
Data/Logic/Normal/Implicative.hs view
@@ -1,27 +1,53 @@ {-# LANGUAGE DeriveDataTypeable, PackageImports, RankNTypes, ScopedTypeVariables #-} {-# OPTIONS -Wall #-} module Data.Logic.Normal.Implicative-    ( ImplicativeForm(INF, neg, pos)+    ( LiteralMapT+    , NormalT+    , runNormal+    , runNormalT+    , ImplicativeForm(INF, neg, pos)     , makeINF'     , implicativeNormalForm     , prettyINF     , prettyProof     ) where -import Data.Logic.Normal.Clause (clauseNormalForm)-import Data.Logic.Normal.Skolem (NormalT)--import "mtl" Control.Monad.State (MonadPlus, msum)+import Control.Monad.Identity (Identity(runIdentity))+import Control.Monad.State (StateT(runStateT), MonadPlus, msum) import Data.Generics (Data, Typeable, listify) import Data.List (intersperse)+import Data.Logic.Classes.Constants (Constants(true), ifElse) import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..))+import Data.Logic.Classes.Formula (Formula) import Data.Logic.Classes.Skolem (Skolem(fromSkolem)) import Data.Logic.Classes.Literal (Literal(..))-import Data.Logic.Classes.Negatable (Negatable(..))+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 Data.Maybe (isJust) import Text.PrettyPrint (Doc, cat, text, hsep) +-- |Combination of Normal monad and LiteralMap monad+type NormalT formula v term m a = SkolemT v term (LiteralMapT formula m) a++runNormalT :: Monad m => NormalT formula v term m a -> m a+runNormalT action = runLiteralMapM (runSkolemT action)++runNormal :: NormalT formula v term Identity a -> a+runNormal = runIdentity . runNormalT+ +--type LiteralMap f = LiteralMapT f Identity+type LiteralMapT f = StateT (Int, Map.Map f Int)++--runLiteralMap :: LiteralMap p a -> a+--runLiteralMap action = runIdentity (runLiteralMapM action)++runLiteralMapM :: Monad m => LiteralMapT f m a -> m a+runLiteralMapM action = (runStateT action) (1, Map.empty) >>= return . fst+ -- |A type to represent a formula in Implicative Normal Form.  Such a -- formula has the form @a & b & c .=>. d | e | f@, where a thru f are -- literals.  One more restriction that is not implied by the type is@@ -62,9 +88,10 @@ --    a | b | c => e --    a | b | c => f -- @-implicativeNormalForm :: forall m formula term v p f lit. -                         (Monad m, FirstOrderFormula formula term v p f, Data formula, Literal lit term v p f) =>-                         formula -> NormalT v term m (Set.Set (ImplicativeForm lit))+implicativeNormalForm :: forall m formula atom term v f lit. +                         (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Data formula, Literal lit atom v, Term term v f,+                          Eq formula, Eq lit, Ord lit, Data lit, Skolem f) =>+                         formula -> SkolemT v term m (Set.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)@@ -75,6 +102,7 @@       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))                       (\ _ -> (n, Set.insert f p))                       f       split :: (Set.Set lit, Set.Set lit) -> Set.Set (Set.Set lit, Set.Set lit)
− Data/Logic/Normal/Negation.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}-{-# OPTIONS -Wall #-}-module Data.Logic.Normal.Negation-    ( negationNormalForm-    , nnf-    , simplify-    ) where--import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), freeVars, quant, Quant(..), Predicate(..))-import Data.Logic.Classes.Propositional (Combine(..), combine, BinOp(..))-import Data.Logic.Classes.Pred (Pred(..), pApp)-import Data.Logic.Classes.Boolean (Boolean(..))-import Data.Logic.Classes.Negatable (Negatable(..))-import Data.Logic.Classes.Logic (Logic(..))-import qualified Data.Set.Extra as S---- | Simplify and recursively apply nnf.-negationNormalForm :: FirstOrderFormula formula term v p f => formula -> formula-negationNormalForm = nnf . simplify---- |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 :: FirstOrderFormula formula term v p f => formula -> formula-nnf fm =-    foldFirstOrder nnfQuant nnfCombine (\ _ -> fm) fm-    where-      nnfQuant op v p = quant op v (nnf p)-      nnfCombine ((:~:) p) = foldFirstOrder nnfNotQuant nnfNotCombine (\ _ -> 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 All 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---- |Do a bottom-up recursion to simplify a formula.-simplify :: FirstOrderFormula formula term v p f => formula -> formula-simplify fm =-    foldFirstOrder (\ op v p -> simplify1 (quant op v (simplify p)))-          (\ cm -> case cm of-                     (:~:) p -> simplify1 ((.~.) (simplify p))-                     BinOp p op q -> simplify1 (combine (BinOp (simplify p) op (simplify q))))-          (\ _ -> simplify1 fm)-          fm---- |Extend psimplify1 to handle quantifiers.  Any quantifier which has--- no corresponding free occurrences of the quantified variable is--- eliminated.-simplify1 :: FirstOrderFormula formula term v p f => formula -> formula-simplify1 fm =-    foldFirstOrder (\ _ v p -> if S.member v (freeVars p) then fm else p)-          (\ _ -> psimplify1 fm)-          (\ _ -> psimplify1 fm)-          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 term v p f. FirstOrderFormula formula term v p f => formula -> formula-psimplify1 fm =-    foldFirstOrder (\ _ _ _ -> fm) simplifyCombine (\ _ -> fm) fm-    where-      simplifyCombine ((:~:) f) = foldFirstOrder (\ _ _ _ -> fm) simplifyNotCombine simplifyNotPred f-      simplifyCombine (BinOp l op r) =-          case (pBool l, op, pBool 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 ((:~:) f) = f-      simplifyNotCombine _ = fm-      simplifyNotPred (Apply pr ts)-          | pr == fromBool False = pApp0 (fromBool True)-          | pr == fromBool True = pApp0 (fromBool False)-          | True = (.~.) (pApp pr ts)-      simplifyNotPred (Constant x) = pApp0 (fromBool (not x))-      simplifyNotPred (Equal t1 t2) = t1 .!=. t2-      simplifyNotPred (NotEqual t1 t2) = t1 .=. t2-      -- Return a Maybe Bool depending upon whether a formula is true,-      -- false, or something else.-      pBool :: formula -> Maybe Bool-      pBool = foldFirstOrder (\ _ _ _ -> Nothing) (\ _ -> Nothing) p-          where p (Apply pr _ts) =-                    if pr == fromBool True-                    then Just True-                    else if pr == fromBool False-                         then Just False-                         else Nothing-                p _ = Nothing
− Data/Logic/Normal/Prenex.hs 
@@ -1,75 +0,0 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}-{-# OPTIONS -Wall #-}-module Data.Logic.Normal.Prenex-    ( prenexNormalForm-    ) where--import Data.Logic.Normal.Negation (negationNormalForm)--import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), freeVars, quant, Quant(..), substitute)-import Data.Logic.Classes.Propositional (Combine(..), BinOp(..))-import Data.Logic.Classes.Logic (Logic(..))-import Data.Logic.Classes.Term (Term(var))-import Data.Logic.Classes.Variable (variant)---- |Convert to Prenex normal form, with all quantifiers at the left.-prenexNormalForm :: (FirstOrderFormula formula term v p f) => formula -> formula-prenexNormalForm = prenex . negationNormalForm---- |Recursivly apply pullQuants anywhere a quantifier might not be--- leftmost.-prenex :: (FirstOrderFormula formula term v p f) => formula -> formula -prenex fm =-    foldFirstOrder q c (\ _ -> fm) fm-    where-      q op x p = quant op x (prenex p)-      c (BinOp l (:&:) r) = pullQuants (prenex l .&. prenex r)-      c (BinOp l (:|:) r) = pullQuants (prenex l .|. prenex r)-      c _ = fm---- |Perform transformations to move quantifiers outside of binary--- operators:--- --- @---  Formula            Rewrites to---  (1) ∀x F[x] & G        ∀x    (F[x] & G)---  (2) ∀x F[x] & ∀x G[x]  ∀x ∀x (F[x] & G[x])---  (3) ∃x F[x] & G        ∃x    (F[x] & G)---  (4) ∃x F[x] & ∃x G[x]  ∃x Yz (F[x] & G[z]) -- rename--- ---  (5) ∀x F[x] | G        ∀x    (F[x] | G)---  (6) ∀x F[x] | ∀x G[x]  ∀x ∀z (F[x] | G[z]) -- rename---  (7) ∃x F[x] | G        ∃x    (F[x] | G)---  (8) ∃x F[x] | ∃x G[x]  ∃x Yx (F[x] | G[x])--- @-pullQuants :: forall formula term v p f. (FirstOrderFormula formula term v p f) => formula -> formula-pullQuants fm =-    foldFirstOrder (\ _ _ _ -> fm) pullQuantsCombine (\ _ -> fm) fm-    where-      getQuant = foldFirstOrder (\ op v f -> Just (op, v, f)) (\ _ -> Nothing) (\ _ -> Nothing)-      pullQuantsCombine ((:~:) _) = fm-      pullQuantsCombine (BinOp l op r) = -          case (getQuant l, op, getQuant r) of-            (Just (All, vl, l'),    (:&:), Just (All, 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 (All, vl, l'),    (:&:), _)                     -> pullq True  False fm for_all (.&.) vl vl l' r-            (_,                     (:&:), Just (All, vr, r'))    -> pullq False True  fm for_all (.&.) vr vr l  r'-            (Just (All, vl, l'),    (:|:), _)                     -> pullq True  False fm for_all (.|.) vl vl l' r-            (_,                     (:|:), Just (All, 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 term v p 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 (freeVars fm) x-        p' = if l then substitute x (var z) p else p-        q' = if r then substitute y (var z) q else q-        fm' = pullQuants (op p' q') in-    mkq z fm'
− Data/Logic/Normal/Skolem.hs 
@@ -1,120 +0,0 @@-{-# LANGUAGE PackageImports, RankNTypes, ScopedTypeVariables #-}-{-# OPTIONS -Wall #-}-module Data.Logic.Normal.Skolem-    ( LiteralMapT-    , NormalT-    , runNormalT-    , runNormal-    , NormalT'-    , runNormalT'-    , runNormal'-    , skolemNormalForm-    ) where--import Data.Logic.Normal.Negation (negationNormalForm)-import Data.Logic.Normal.Prenex (prenexNormalForm)--import "mtl" Control.Monad.Identity (Identity(runIdentity))-import "mtl" Control.Monad.State (StateT(runStateT), get, put)-import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), freeVars, Quant(..), substitute)-import Data.Logic.Classes.Propositional (Combine(..), BinOp(..))-import Data.Logic.Classes.Logic (Logic(..))-import Data.Logic.Classes.Term (Term(var, fApp))-import Data.Logic.Classes.Skolem (Skolem(toSkolem))-import qualified Data.Map as Map-import qualified Data.Set as Set- ---type LiteralMap f = LiteralMapT f Identity-type LiteralMapT f = StateT (Int, Map.Map f Int)----runLiteralMap :: LiteralMap p a -> a---runLiteralMap action = runIdentity (runLiteralMapM action)--runLiteralMapM :: Monad m => LiteralMapT f m a -> m a-runLiteralMapM action = (runStateT action) (1, Map.empty) >>= return . fst---- |The logic monad contains (will contain) several types of state to--- support the operations done on logic formulas: Skolemization,--- literal substitution, and the set of support during a proof--- procedure.-data LogicState v term-    = LogicState-      { skolemCount :: Int-        -- ^ The next available Skolem number.-      , skolemMap :: Map.Map v term-        -- ^ Map from variables to applications of a Skolem function-      , 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.-      }--newLogicState :: LogicState v term-newLogicState = LogicState { skolemCount = 1-                           , skolemMap = Map.empty-                           , univQuant = [] }--type NormalT v term m = StateT (LogicState v term) m--runNormalT :: Monad m => NormalT v term m a -> m a-runNormalT action = (runStateT action) newLogicState >>= return . fst--runNormal :: NormalT v term Identity a -> a-runNormal = runIdentity . runNormalT---- |Combination of Normal monad and LiteralMap monad-type NormalT' formula v term m a = NormalT v term (LiteralMapT formula m) a--runNormalT' :: Monad m => NormalT' formula v term m a -> m a-runNormalT' action = runLiteralMapM (runNormalT action)--runNormal' :: NormalT' formula v term Identity a -> a-runNormal' = runIdentity . runNormalT'---- |We get Skolem Normal Form by skolemizing and then converting to--- Prenex Normal Form, and finally eliminating the remaining quantifiers.-skolemNormalForm :: (Monad m, FirstOrderFormula formula term v p f) => formula -> NormalT v term m formula-skolemNormalForm f = askolemize f >>= return . specialize . prenexNormalForm---- |I need to consult the Harrison book for the reasons why we don't--- |just Skolemize the result of prenexNormalForm.-askolemize :: (Monad m, FirstOrderFormula formula term v p f) => formula -> NormalT v term m formula-askolemize = skolem . negationNormalForm {- nnf . simplify -}---- |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 NormalT 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 formula term v p f) => formula -> NormalT v term m formula-skolem fm =-    foldFirstOrder q c (\ _ -> return fm) fm-    where-      q Exists y p =-          do let xs = freeVars fm-             state <- get-             let f = toSkolem (skolemCount state)-             put (state {skolemCount = skolemCount state + 1})-             let fx = fApp f (map var (Set.toList xs))-             skolem (substitute y fx p)-      q All x p = skolem p >>= return . for_all x-      c (BinOp l (:&:) r) = skolem2 (.&.) l r-      c (BinOp l (:|:) r) = skolem2 (.|.) l r-      c _ = return fm--skolem2 :: (Monad m, FirstOrderFormula formula term v p f) =>-           (formula -> formula -> formula) -> formula -> formula -> NormalT v term m formula-skolem2 cons p q =-    skolem p >>= \ p' ->-    skolem q >>= \ q' ->-    return (cons p' q')--specialize :: FirstOrderFormula formula term v p f => formula -> formula-specialize f =-    foldFirstOrder q (\ _ -> f) (\ _ -> f) f-    where-      q All _ f' = specialize f'-      q _ _ _ = f
Data/Logic/Resolution.hs view
@@ -9,24 +9,26 @@     , getSetOfSupport     , SetOfSupport     , Unification-    , Subst )-    where+    , isRenameOfAtomEq+    , getSubstAtomEq+    ) where +import Data.Logic.Classes.Constants (fromBool)+import Data.Logic.Classes.Equals (AtomEq(foldAtomEq, equals), applyEq, zipAtomsEq)+import Data.Logic.Classes.Formula (Formula(isRename, getSubst))+import Data.Logic.Classes.Literal (Literal(..), zipLiterals) import Data.Logic.Classes.Term (Term(..))-import Data.Logic.Classes.Literal (Literal(..), PredicateLit(..)) 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 M+import qualified Data.Map as Map import Data.Maybe (isJust) -type Subst v term = Map v term- type SetOfSupport lit v term = S.Set (Unification lit v term) -type Unification lit v term = (ImplicativeForm lit, Subst v term)+type Unification lit v term = (ImplicativeForm lit, Map.Map v term) -prove :: (Literal lit term v p f, Show v, Show term) =>+prove :: (Literal lit atom v, Formula atom term v, Term term v f, Ord lit, Ord term, Ord v, Show v, Show term, AtomEq atom p term, Eq p) =>          Maybe Int -- ^ Recursion limit.  We continue recursing until this                    -- becomes zero.  If it is negative it may recurse until                    -- it overflows the stack.@@ -51,8 +53,8 @@ --         (True, (ss1 ++ [s] ++ss')) --       else --         prove (ss1 ++ [s]) ss' (fst s:kb)-prove' :: forall lit p f v term.-          Literal lit term v p f =>+prove' :: forall lit atom p f v term.+          (Literal lit atom v, Formula atom term v, Term term v f, Ord lit, Ord term, Ord v, AtomEq atom p term, 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@@ -64,8 +66,8 @@     in       if S.null ss' then (ss1, False) else (S.union ss1 ss', tf) -getResult :: Literal lit term v p f =>-             (SetOfSupport lit v term) -> S.Set (Maybe (Unification lit v term)) -> ((SetOfSupport lit v term), Bool)+getResult :: (Literal lit atom v, Formula atom term v, Term term v f, Ord lit, Ord term, Ord v, AtomEq atom p term, Eq p) =>+             SetOfSupport lit v term -> S.Set (Maybe (Unification lit v term)) -> ((SetOfSupport lit v term), Bool) getResult ss us =     case S.minView us of       Nothing ->@@ -92,29 +94,31 @@ -}  -- |Convert the "question" to a set of support.-getSetOfSupport :: (Literal formula term v p f) =>-                   S.Set (ImplicativeForm formula) -> S.Set (ImplicativeForm formula, Subst v term)+getSetOfSupport :: (Literal formula atom v, Formula atom term v, Term term v f, Ord formula, Ord term, Ord v) =>+                   S.Set (ImplicativeForm formula) -> S.Set (ImplicativeForm formula, Map.Map v term) getSetOfSupport s = S.map (\ x -> (x, getSubsts x empty)) s -getSubsts :: (Literal formula term v p f) =>-             ImplicativeForm formula -> Subst v term -> Subst v term+getSubsts :: (Literal formula atom v, Formula atom term v, Term term v f, Ord formula) =>+             ImplicativeForm formula -> Map.Map v term -> Map.Map v term getSubsts inf theta =     getSubstSentences (pos inf) (getSubstSentences (neg inf) theta) -getSubstSentences :: Literal formula term v p f => S.Set formula -> Subst v term -> Subst v term+getSubstSentences :: (Literal formula atom v, Formula atom term v, Term term v f) => S.Set formula -> Map.Map v term -> Map.Map v term getSubstSentences xs theta = foldr getSubstSentence theta (S.toList xs)  -getSubstSentence :: Literal formula term v p f => formula -> Subst v term -> Subst v term+getSubstSentence :: (Literal formula atom v, Formula atom term v, Term term v f)  => formula -> Map.Map v term -> Map.Map v term getSubstSentence formula theta =     foldLiteral           (\ s -> getSubstSentence s theta)-          (\ pa -> case pa of-                     EqualLit t1 t2 -> getSubstsTerms [t1, t2] theta-                     ApplyLit _ ts -> getSubstsTerms ts theta)+          (const theta)+          (getSubst theta)           formula -getSubstsTerms :: Term term v f => [term] -> Subst v term -> Subst v term+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)++getSubstsTerms :: Term term v f => [term] -> Map.Map v term -> Map.Map v term getSubstsTerms [] theta = theta getSubstsTerms (x:xs) theta =     let@@ -123,13 +127,13 @@     in       theta'' -getSubstsTerm :: Term term v f => term -> Subst v term -> Subst v term+getSubstsTerm :: Term term v f => term -> Map.Map v term -> Map.Map v term getSubstsTerm term theta =-    foldTerm (\ v -> M.insertWith (\ _ old -> old) v (var v) theta)+    foldTerm (\ v -> Map.insertWith (\ _ old -> old) v (vt v) theta)              (\ _ ts -> getSubstsTerms ts theta)              term -isRenameOf :: Literal lit term v p f =>+isRenameOf :: (Literal lit atom v, Formula atom term v, Term term v f, Ord lit) =>               ImplicativeForm lit -> ImplicativeForm lit -> Bool isRenameOf inf1 inf2 =     (isRenameOfSentences lhs1 lhs2) && (isRenameOfSentences rhs1 rhs2)@@ -139,25 +143,29 @@       lhs2 = neg inf2       rhs2 = pos inf2 -isRenameOfSentences :: Literal lit term v p f => S.Set lit -> S.Set lit -> Bool+isRenameOfSentences :: (Literal lit atom v, Formula atom term v, Term term v f) => 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 formula term v p f. Literal formula term v p f => formula -> formula -> Bool+isRenameOfSentence :: forall formula atom term v f. (Literal formula atom v, Formula atom term v, Term term v f) => formula -> formula -> Bool isRenameOfSentence f1 f2 =     maybe False id $-    zipLiterals (\ _ _ -> Just False) p f1 f2-    where p :: PredicateLit p term -> PredicateLit p term -> Maybe Bool-          p (EqualLit t1l t1r) (EqualLit t2l t2r) = Just (isRenameOfTerm t1l t2l && isRenameOfTerm t1r t2r)-          p (ApplyLit p1 ts1) (ApplyLit p2 ts2) = Just (p1 == p2 && isRenameOfTerms ts1 ts2)-          p _ _ = Nothing+    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 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))+               a1 a2+ isRenameOfTerm :: Term term v f => term -> term -> Bool isRenameOfTerm t1 t2 =     maybe False id $-    zipT (\ _ _ -> Just True)-         (\ f1 ts1 f2 ts2 -> Just (f1 == f2 && isRenameOfTerms ts1 ts2))-         t1 t2+    zipTerms (\ _ _ -> Just True)+             (\ f1 ts1 f2 ts2 -> Just (f1 == f2 && isRenameOfTerms ts1 ts2))+             t1 t2  isRenameOfTerms :: Term term v f => [term] -> [term] -> Bool isRenameOfTerms ts1 ts2 =@@ -169,8 +177,8 @@     else       False -resolution :: forall lit p f term v. Literal lit term v p f =>-             (ImplicativeForm lit, Subst v term) -> (ImplicativeForm lit, Subst v term) -> Maybe (ImplicativeForm lit, Map v term)+resolution :: forall lit atom p f term v. (Literal lit atom v, Formula 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 (inf1, theta1) (inf2, theta2) =     let         lhs1 = neg inf1@@ -186,17 +194,17 @@                               (S.catMaybes $ S.map (\s -> subst s theta2') lhs2')               rhs'' = S.union (S.catMaybes $ S.map (\s -> subst s theta1') rhs1')                               (S.catMaybes $ S.map (\s -> subst s theta2') rhs2)-              theta = M.unionWith (\ l _r -> l) (updateSubst theta1 theta1') (updateSubst theta2 theta2')+              theta = Map.unionWith (\ l _r -> l) (updateSubst theta1 theta1') (updateSubst theta2 theta2')             in               Just (INF lhs'' rhs'', theta)         Nothing -> Nothing     where-      tryUnify :: (Literal formula term v p f, Ord formula) =>-                  S.Set formula -> S.Set formula -> Maybe ((S.Set formula, Subst v term), (S.Set formula, Subst v term))+      tryUnify :: (Literal formula atom v, Ord formula) =>+                  S.Set formula -> S.Set formula -> Maybe ((S.Set formula, Map.Map v term), (S.Set formula, Map.Map v term))       tryUnify lhs rhs = tryUnify' lhs rhs S.empty                          -      tryUnify' :: (Literal formula term v p f, Ord formula) =>-                   S.Set formula -> S.Set formula -> S.Set formula -> Maybe ((S.Set formula, Subst v term), (S.Set formula, Subst v term))+      tryUnify' :: (Literal formula atom v, Ord formula) =>+                   S.Set formula -> S.Set formula -> S.Set formula -> Maybe ((S.Set formula, Map.Map v term), (S.Set formula, Map.Map v term))       tryUnify' lhss _ _ | S.null lhss = Nothing       tryUnify' lhss'' rhss lhss' =           let (lhs, lhss) = S.deleteFindMin lhss'' in@@ -205,8 +213,8 @@             Just (rhss', theta1', theta2') ->                 Just ((S.union lhss' lhss, theta1'), (rhss', theta2')) -      tryUnify'' :: (Literal formula term v p f, Ord formula) =>-                    formula -> S.Set formula -> S.Set formula -> Maybe (S.Set formula, Subst v term, Subst v term)+      tryUnify'' :: (Literal formula atom v, Ord formula) =>+                    formula -> S.Set formula -> S.Set formula -> Maybe (S.Set formula, Map.Map v term, Map.Map v term)       tryUnify'' _x rhss _ | S.null rhss = Nothing       tryUnify'' x rhss'' rhss' =           let (rhs, rhss) = S.deleteFindMin rhss'' in@@ -215,55 +223,59 @@             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 term v p f) =>+demodulate :: (Literal lit atom v, Formula atom term v, Term term v f, Eq lit, Ord lit, Eq term, Ord v, AtomEq atom p term) =>               (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") p lit1+          foldLiteral (\ _ -> error "demodulate") (\ _ -> Nothing) (foldAtomEq (\ _ _ -> Nothing) (\ _ -> Nothing) p) lit1       _ -> Nothing     where-      p (EqualLit t1 t2) =+      p t1 t2 =           case findUnify t1 t2 (S.union lhs2 rhs2) of             Just ((t1', t2'), theta1', theta2') ->                 let substNeg2 = S.catMaybes $ S.map (\x -> subst x theta2') lhs2                     substPos2 = S.catMaybes $ S.map (\x -> subst x theta2') rhs2                     lhs = S.catMaybes $ S.map (\x -> replaceTerm x (t1', t2')) substNeg2                     rhs = S.catMaybes $ S.map (\x -> replaceTerm x (t1', t2')) substPos2-                    theta = M.unionWith (\ l _r -> l) (updateSubst theta1 theta1') (updateSubst theta2 theta2') in+                    theta = Map.unionWith (\ l _r -> l) (updateSubst theta1 theta1') (updateSubst theta2 theta2') in                 Just (INF lhs rhs, theta)             Nothing -> Nothing-      p _ = Nothing       lhs2 = neg inf2       rhs2 = pos inf2  -- |Unification: unifies two sentences.-unify :: Literal formula term v p f => formula -> formula -> Maybe (Subst v term, Subst v term)+unify :: (Literal formula atom v, Formula atom term v, Term term v f, AtomEq atom p term, Eq p) =>+         formula -> formula -> Maybe (Map.Map v term, Map.Map v term) unify s1 s2 = unify' s1 s2 empty empty -unify' :: Literal formula term v p f =>-          formula -> formula -> Subst v term -> Subst v term -> Maybe (Subst v term, Subst v term)+unify' :: (Literal formula atom v, Formula atom term v, Term term v f, AtomEq atom p term, Eq p) =>+          formula -> formula -> 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'")-         (\ pa1 pa2 ->-              case (pa1, pa2) of-                (EqualLit l1 r1, EqualLit l2 r2) -> unifyTerms [l1, r1] [l2, r2] theta1 theta2-                (ApplyLit p1 ts1, ApplyLit p2 ts2) -> if p1 == p2 then unifyTerms ts1 ts2 theta1 theta2 else Nothing-                _ -> Nothing)+         (\ x y -> if x == y then unifyTerms [] [] theta1 theta2 else Nothing)+         (unify2AtomsEq theta1 theta2)          f1 f2 -unifyTerm :: Term term v f => term -> term -> Subst v term -> Subst v term -> Maybe (Subst v term, Subst v term)+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 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)+               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 t1 t2 theta1 theta2 =     foldTerm           (\ v1 ->-               maybe (Just (M.insert v1 t2 theta1, theta2))+               maybe (if vt v1 == t2 then Nothing else Just (Map.insert v1 t2 theta1, theta2))                      (\ t1' -> unifyTerm t1' t2 theta1 theta2)-                     (M.lookup v1 theta1))+                     (Map.lookup v1 theta1))           (\ f1 ts1 ->-               foldTerm (\ v2 -> maybe (Just (theta1, M.insert v2 t1 theta2))+               foldTerm (\ v2 -> maybe (Just (theta1, Map.insert v2 t1 theta2))                                  (\ t2' -> unifyTerm t1 t2' theta1 theta2)-                                 (M.lookup v2 theta2))+                                 (Map.lookup v2 theta2))                         (\ f2 ts2 -> if f1 == f2                                      then unifyTerms ts1 ts2 theta1 theta2                                      else Nothing)@@ -271,7 +283,7 @@           t1  unifyTerms :: Term term v f =>-              [term] -> [term] -> Subst v term -> Subst v term -> Maybe (Subst v term, Subst v 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:ts1) (t2:ts2) theta1 theta2 =     case (unifyTerm t1 t2 theta1 theta2) of@@ -279,11 +291,11 @@       Just (theta1',theta2') -> unifyTerms ts1 ts2 theta1' theta2' unifyTerms _ _ _ _ = Nothing -findUnify :: forall formula term v p f. (Literal formula term v p f, Term term v f) =>-             term -> term -> S.Set formula -> Maybe ((term, term), Subst v term, Subst v term)+findUnify :: forall formula atom term v p f. (Literal formula atom v, Formula atom term v, Term term v f, AtomEq atom p term) =>+             term -> term -> S.Set formula -> Maybe ((term, term), Map.Map v term, Map.Map v term) findUnify tl tr s =     let-      terms = concatMap (foldLiteral (\ (_ :: formula) -> error "getTerms") p) (S.toList s)+      terms = concatMap (foldLiteral (\ (_ :: formula) -> error "getTerms") (\ _ -> []) p) (S.toList s)       unifiedTerms' = map (\t -> unifyTerm tl t empty empty) terms       unifiedTerms = filter isJust unifiedTerms'     in@@ -294,64 +306,65 @@        (Nothing:_) -> error "findUnify"     where       -- getTerms formula = foldLiteral (\ _ -> error "getTerms") p formula-      p :: PredicateLit p term -> [term]-      p (EqualLit t1 t2) = getTerms' t1 ++ getTerms' t2-      p (ApplyLit _ ts) = concatMap getTerms' ts+      p :: atom -> [term]+      p = foldAtomEq (\ _ ts -> concatMap getTerms' ts) (const []) (\ t1 t2 -> getTerms' t1 ++ getTerms' t2)       getTerms' :: term -> [term]-      getTerms' t = foldTerm (\ v -> [var v]) (\ f ts -> fApp f ts : concatMap getTerms' ts) t+      getTerms' t = foldTerm (\ v -> [vt v]) (\ f ts -> fApp f ts : concatMap getTerms' ts) t  {--getTerms :: Literal formula term v p f => formula -> [term]+getTerms :: Literal formula atom v => formula -> [term] getTerms formula =     foldLiteral (\ _ -> error "getTerms") p formula     where-      getTerms' t = foldT (\ v -> [var v]) (\ f ts -> fApp f ts : concatMap getTerms' ts) t+      getTerms' t = foldT (\ v -> [vt v]) (\ f ts -> fApp f ts : concatMap getTerms' ts) t       p (Equal t1 t2) = getTerms' t1 ++ getTerms' t2       p (Apply _ ts) = concatMap getTerms' ts -} -replaceTerm :: (Literal lit term v p f) => lit -> (term, term) -> Maybe lit+replaceTerm :: (Literal lit atom v, Formula atom term v, Term term v f, Eq term, AtomEq atom p term) => lit -> (term, term) -> Maybe lit replaceTerm formula (tl', tr') =     foldLiteral           (\ _ -> error "error in replaceTerm")-          (\ pa -> case pa of-                     EqualLit t1 t2 ->-                         let t1' = replaceTerm' t1-                             t2' = replaceTerm' t2 in-                         if t1' == t2' then Nothing else Just (t1' `equals` t2')-                     ApplyLit p ts -> Just (pAppLiteral p (map (\ t -> replaceTerm' t) ts)))+          (\ x -> Just (atomic (applyEq (fromBool x) [])))+          (foldAtomEq (\ p ts -> Just (atomic (applyEq p (map (\ t -> replaceTerm' t) ts))))+                      (\ x -> Just (atomic (applyEq (fromBool x) [])))+                      (\ t1 t2 -> +                           let t1' = replaceTerm' t1+                               t2' = replaceTerm' t2 in+                           if t1' == t2' then Nothing else Just (atomic (t1' `equals` t2'))))           formula     where       replaceTerm' t =           if termEq t tl'           then tr'-          else foldTerm var (\ f ts -> fApp f (map replaceTerm' ts)) t+          else foldTerm vt (\ f ts -> fApp f (map replaceTerm' ts)) t       termEq t1 t2 =-          maybe False id (zipT (\ 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 (\ v1 v2 -> Just (v1 == v2)) (\ f1 ts1 f2 ts2 -> Just (f1 == f2 && length ts1 == length ts2 && all (uncurry termEq) (zip ts1 ts2))) t1 t2) -subst :: Literal formula term v p f => formula -> Subst v term -> Maybe formula+subst :: (Literal formula atom v, AtomEq atom p term, Formula atom term v, Term term v f, Eq term) => formula -> Map.Map v term -> Maybe formula subst formula theta =     foldLiteral           (\ _ -> Just formula)-          (\ pa -> case pa of-                     EqualLit t1 t2 ->-                         let t1' = substTerm t1 theta-                             t2' = substTerm t2 theta in-                         if t1' == t2' then Nothing else Just (t1' `equals` t2')-                     ApplyLit p ts -> Just (pAppLiteral p (substTerms ts theta)))+          (\ x -> Just (atomic (applyEq (fromBool x) [])))+          (foldAtomEq (\ p ts -> Just (atomic (applyEq p (substTerms ts theta))))+                      (\ x -> Just (atomic (applyEq (fromBool x) [])))+                      (\ t1 t2 ->+                           let t1' = substTerm t1 theta+                               t2' = substTerm t2 theta in+                           if t1' == t2' then Nothing else Just (atomic (t1' `equals` t2'))))           formula -substTerm :: Term term v f => term -> Subst v term -> term+substTerm :: Term term v f => term -> Map.Map v term -> term substTerm term theta =-    foldTerm (\ v -> maybe term id (M.lookup v theta))+    foldTerm (\ v -> maybe term id (Map.lookup v theta))              (\ f ts -> fApp f (substTerms ts theta))              term -substTerms :: Term term v f => [term] -> Subst v term -> [term]+substTerms :: Term term v f => [term] -> Map.Map v term -> [term] substTerms ts theta = map (\t -> substTerm t theta) ts -updateSubst :: Term term v f => Subst v term -> Subst v term -> Subst v term-updateSubst theta1 theta2 = M.union theta1 (M.intersection theta1 theta2)+updateSubst :: Term term v f => 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 _ | M.null theta1 = M.empty---updateSubst theta1 theta2 = M.unionWith (\ _ term2 -> term2) theta1 theta2+--updateSubst theta1 _ | Map.null theta1 = Map.empty+--updateSubst theta1 theta2 = Map.unionWith (\ _ term2 -> term2) theta1 theta2
Data/Logic/Satisfiable.hs view
@@ -13,32 +13,34 @@  import qualified Data.Set as Set import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), toPropositional)+import Data.Logic.Classes.Formula (Formula) import Data.Logic.Classes.Literal (Literal)-import Data.Logic.Classes.Negatable ((.~.))+import Data.Logic.Classes.Negate ((.~.))+import Data.Logic.Classes.Term (Term)+import Data.Logic.Harrison.Skolem (SkolemT) import Data.Logic.Instances.PropLogic () import Data.Logic.Normal.Clause (clauseNormalForm)-import Data.Logic.Normal.Skolem (NormalT) import qualified PropLogic as PL  -- |Is there any variable assignment that makes the formula true?-satisfiable :: forall formula term v p f m. (Monad m, FirstOrderFormula formula term v p f, Ord formula, Literal formula term v p f) =>-                formula -> NormalT v term m Bool+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) =>+                formula -> SkolemT v term m 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'  -- |Is the formula always false?  (Not satisfiable.)-inconsistant :: (Monad m, FirstOrderFormula formula term v p f, Ord formula, Literal formula term v p f) =>-                formula -> NormalT v term m Bool+inconsistant :: (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f, Ord formula, Literal formula atom v) =>+                formula -> SkolemT v term m Bool inconsistant f =  satisfiable f >>= return . not  -- |Is the negation of the formula inconsistant?-theorem :: (Monad m, FirstOrderFormula formula term v p f, Ord formula, Literal formula term v p f) =>-           formula -> NormalT v term m Bool+theorem :: (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f, Ord formula, Literal formula atom v) =>+           formula -> SkolemT v term m Bool theorem f = inconsistant ((.~.) f)  -- |A formula is invalid if it is neither a theorem nor inconsistent.-invalid :: (Monad m, FirstOrderFormula formula term v p f, Ord formula, Literal formula term v p f) =>-           formula -> NormalT v term m Bool+invalid :: (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f, Ord formula, Literal formula atom v) =>+           formula -> SkolemT v term m Bool invalid f = inconsistant f >>= \ fi -> theorem f >>= \ ft -> return (not (fi || ft))
− Data/Logic/Test.hs 
@@ -1,243 +0,0 @@--- |Types to use for creating test cases.  These are used in the Logic--- package test cases, and are exported for use in its clients.-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, RankNTypes, ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances #-}-{-# OPTIONS -Wwarn #-}-module Data.Logic.Test-    ( -- * Formula parameter types-      V(..)-    , Pr(..)-    , AtomicFunction(..)-    , TFormula-    , TTerm-    , prettyV-    , prettyP-    , prettyF-      -- * Test case types-    , TestFormula(..)-    , Expected(..)-    , doTest-    , TestProof(..)-    , ProofExpected(..)-    , doProof-    ) where--import Control.Monad.Reader (MonadPlus(..), msum)-import Data.Boolean.SatSolver (CNF)-import Data.Char (isDigit)-import Data.Generics (Data, Typeable, listify)---import Data.Logic.Clause (ClauseNormalFormula(satisfiable))-import Data.Logic.Classes.Boolean (Boolean(..))-import Data.Logic.Classes.ClauseNormalForm (ClauseNormalFormula(satisfiable))-import Data.Logic.Classes.FirstOrder (FirstOrderFormula, convertFOF)-import Data.Logic.Classes.Literal (Literal)-import Data.Logic.Classes.Skolem (Skolem(..))-import Data.Logic.Classes.Variable (Variable(one, next))---import qualified Data.Logic.Instances.Chiou as C-import qualified Data.Logic.Types.FirstOrder as P-import Data.Logic.Instances.PropLogic (plSat)-import qualified Data.Logic.Instances.SatSolver as SS-import Data.Logic.KnowledgeBase (WithId, runProver', Proof, loadKB, theoremKB, getKB)-import Data.Logic.Normal.Clause (clauseNormalForm, trivial)-import Data.Logic.Normal.Negation (negationNormalForm, simplify)-import Data.Logic.Normal.Prenex (prenexNormalForm)-import Data.Logic.Normal.Implicative (ImplicativeForm)-import Data.Logic.Normal.Skolem (skolemNormalForm, runNormal, runNormal', runNormalT')-import Data.Logic.Classes.Arity (Arity(arity))-import Data.Logic.Resolution (SetOfSupport)-import qualified Data.Set as S-import Data.String (IsString(fromString))----import PropLogic (PropForm)--import Test.HUnit-import Text.PrettyPrint (Doc, text)--newtype V = V String deriving (Eq, Ord, Data, Typeable)--instance IsString V where-    fromString = V--instance Show V where-    show (V s) = show s--prettyV :: V -> Doc-prettyV (V s) = text s--instance Variable V where-    one = V "x"-    next (V s) =-        V (case break (not . isDigit) (reverse s) of-             (_, "") -> "x"-             ("", nondigits) -> nondigits ++ "2"-             (digits, nondigits) -> nondigits ++ show (1 + read (reverse digits) :: Int))-        --- |A newtype for the Primitive Predicate parameter.-data Pr-    = Pr String-    | T-    | F-    | Equals-    deriving (Eq, Ord, Data, Typeable)--instance IsString Pr where-    fromString = Pr--instance Boolean Pr where-    fromBool True = T-    fromBool False = F--instance Arity Pr where-    arity (Pr _) = Nothing-    arity T = Just 0-    arity F = Just 0-    arity Equals = Just 2--instance Show Pr where-    show T = "fromBool True"-    show F = "fromBool False"-    show Equals = ".=."-    show (Pr s) = show s            -- Because Pr is an instance of IsString--prettyP :: Pr -> Doc-prettyP T = text "True"-prettyP F = text "False"-prettyP Equals = text ".=."-prettyP (Pr s) = text s--data AtomicFunction-    = Fn String-    | Skolem Int-    deriving (Eq, Ord, Data, Typeable)--instance Skolem AtomicFunction where-    toSkolem = Skolem-    fromSkolem (Skolem n) = Just n-    fromSkolem _ = Nothing--instance IsString AtomicFunction where-    fromString = Fn--instance Show AtomicFunction where-    show (Fn s) = show s-    show (Skolem n) = "toSkolem " ++ show n--prettyF :: AtomicFunction -> Doc-prettyF (Fn s) = text s-prettyF (Skolem n) = text ("sK" ++ show n)--type TFormula = P.Formula V Pr AtomicFunction-type TTerm = P.PTerm V AtomicFunction---- |This allows you to use an expression that returns the Doc type in a--- unit test, such as prettyFirstOrder.-instance Eq Doc where-    a == b = show a == show b--data TestFormula formula term v p f-    = TestFormula-      { formula :: formula-      , name :: String-      , expected :: [Expected formula term v p f]-      } deriving (Data, Typeable)---- |Some values that we might expect after transforming the formula.-data (FirstOrderFormula formula term v p f) => Expected formula term v p f-    = FirstOrderFormula formula-    | SimplifiedForm formula-    | NegationNormalForm formula-    | PrenexNormalForm formula-    | SkolemNormalForm formula-    | SkolemNumbers (S.Set Int)-    | ClauseNormalForm (S.Set (S.Set formula))-    | TrivialClauses [(Bool, (S.Set formula))]-    | ConvertToChiou formula-    | ChiouKB1 (Proof formula)-    | PropLogicSat Bool-    | SatSolverCNF CNF-    | SatSolverSat Bool-    deriving (Data, Typeable)--doTest :: (FirstOrderFormula formula term v p f, Literal formula term v p f, Data formula, Show term, Show formula) =>-          TestFormula formula term v p f -> Test-doTest f =-    TestLabel (name f) $ TestList $ -    map doExpected (expected f)-    where-      doExpected (FirstOrderFormula f') =-          TestCase (assertEqual (name f ++ " original formula") (p f') (p (formula f)))-      doExpected (SimplifiedForm f') =-          TestCase (assertEqual (name f ++ " simplified") (p f') (p (simplify (formula f))))-      doExpected (PrenexNormalForm f') =-          TestCase (assertEqual (name f ++ " prenex normal form") (p f') (p (prenexNormalForm (formula f))))-      doExpected (NegationNormalForm f') =-          TestCase (assertEqual (name f ++ " negation normal form") (p f') (p (negationNormalForm (formula f))))-      doExpected (SkolemNormalForm f') =-          TestCase (assertEqual (name f ++ " skolem normal form") (p f') (p (runNormal (skolemNormalForm (formula f)))))-      doExpected (SkolemNumbers f') =-          TestCase (assertEqual (name f ++ " skolem numbers") f' (skolemSet (runNormal (skolemNormalForm (formula f)))))-      doExpected (ClauseNormalForm fss) =-          TestCase (assertEqual (name f ++ " clause normal form") fss (S.map (S.map p) (runNormal (clauseNormalForm (formula f)))))-      doExpected (TrivialClauses flags) =-          TestCase (assertEqual (name f ++ " trivial clauses") flags (map (\ x -> (trivial x, x)) (S.toList (runNormal (clauseNormalForm (formula f))))))-      doExpected (ConvertToChiou result) =-          TestCase (assertEqual (name f ++ " converted to Chiou") result (convertFOF id id id (formula f)))-      doExpected (ChiouKB1 result) =-          TestCase (assertEqual (name f ++ " Chiou KB") result (runProver' Nothing (loadKB [formula f] >>= return . head)))-      doExpected (PropLogicSat result) =-          TestCase (assertEqual (name f ++ " PropLogic.satisfiable") result (runNormal (plSat (formula f))))-      doExpected (SatSolverCNF result) =-          TestCase (assertEqual (name f ++ " SatSolver CNF") (norm result) (runNormal' (SS.toCNF (formula f))))-      doExpected (SatSolverSat result) =-          TestCase (assertEqual (name f ++ " SatSolver CNF") result (null (runNormalT' (SS.toCNF (formula f) >>= satisfiable))))-      p = id--      norm = map S.toList . S.toList . S.fromList . map S.fromList--skolemSet :: (FirstOrderFormula formula term v p f, Data f, Typeable f, Data formula) => formula -> S.Set Int-skolemSet =-    foldr ins S.empty . skolemList-    where-      ins f s = case fromSkolem f of-                  Just n -> S.insert n s-                  Nothing -> s-      skolemList :: (FirstOrderFormula formula term v p f, Data f, Typeable f, Data formula) => formula -> [f]-      skolemList inf = gFind inf :: (Typeable f => [f])---- | @gFind a@ will extract any elements of type @b@ from--- @a@'s structure in accordance with the MonadPlus--- 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)--data TestProof formula term v-    = TestProof-      { proofName :: String-      , proofKnowledge :: (String, [formula])-      , conjecture :: formula-      , proofExpected :: [ProofExpected formula v term]-      } deriving (Data, Typeable)--data ProofExpected formula v term-    = ChiouResult (Bool, SetOfSupport formula v term)-    | ChiouKB (S.Set (WithId (ImplicativeForm formula)))-    deriving (Data, Typeable)--doProof :: forall formula term v p f. (FirstOrderFormula formula term v p f, Literal formula term v p f, Eq term, Show term, Show v, Show formula) =>-           TestProof formula term v -> Test-doProof p =-    TestLabel (proofName p) $ TestList $-    concatMap doExpected (proofExpected p)-    where-      doExpected (ChiouResult result) =-          [TestLabel (proofName p ++ " with " ++ fst (proofKnowledge p)) . TestList $-           [TestCase (assertEqual (proofName p ++ " with " ++ fst (proofKnowledge p) ++ " using Chiou prover")-                      result-                      (runProver' Nothing (loadKB kb >> theoremKB c)))]]-      doExpected (ChiouKB result) =-          [TestLabel (proofName p ++ " with " ++ fst (proofKnowledge p)) . TestList $-           [TestCase (assertEqual (proofName p ++ " with " ++ fst (proofKnowledge p) ++ " Chiou knowledge base")-                      result-                      (runProver' Nothing (loadKB kb >> getKB)))]]-      kb = snd (proofKnowledge p) :: [formula]-      c = conjecture p :: formula
+ Data/Logic/Tests/Chiou0.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings, StandaloneDeriving #-}+{-# OPTIONS -fno-warn-orphans #-}++module Data.Logic.Tests.Chiou0 where++import Control.Monad.Trans (MonadIO, liftIO)+import Data.Logic.Classes.Combine (Combinable(..))+import Data.Logic.Classes.Equals (pApp)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..))+import Data.Logic.Classes.Negate (Negatable(..), (.~.))+import Data.Logic.Classes.Skolem (Skolem(..))+import Data.Logic.Classes.Term (Term(..))+import Data.Logic.Harrison.Skolem (SkolemT)+import Data.Logic.KnowledgeBase (ProverT, runProver', Proof(..), ProofResult(..), loadKB, theoremKB {-, askKB, showKB-})+import Data.Logic.Normal.Implicative (ImplicativeForm(INF), makeINF')+import Data.Logic.Resolution (SetOfSupport)+import Data.Logic.Tests.Common (V(..), AtomicFunction(..), TFormula, TTerm, myTest)+import Data.Map (fromList)+import qualified Data.Set as S+import Test.HUnit++tests :: Test+tests = TestLabel "Test.Chiou0" $ TestList [loadTest, proofTest1, proofTest2]++loadTest :: Test+loadTest =+    myTest "Chiuo0 - loadKB test" expected (runProver' Nothing (loadKB sentences))+    where+      expected :: [Proof TFormula]+      expected = [Proof Invalid (S.fromList [makeINF' ([]) ([(pApp ("Dog") [fApp (toSkolem 1) []])]),+                                             makeINF' ([]) ([(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem 1) []])])]),+                  Proof Invalid (S.fromList [makeINF' ([(pApp ("Dog") [vt ("y2")]),(pApp ("Owns") [vt ("x"),vt ("y")])]) ([(pApp ("AnimalLover") [vt ("x")])])]),+                  Proof Invalid (S.fromList [makeINF' ([(pApp ("Animal") [vt ("y")]),(pApp ("AnimalLover") [vt ("x")]),(pApp ("Kills") [vt ("x"),vt ("y")])]) ([])]),+                  Proof Invalid (S.fromList [makeINF' ([]) ([(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []]),(pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])])]),+                  Proof Invalid (S.fromList [makeINF' ([]) ([(pApp ("Cat") [fApp ("Tuna") []])])]),+                  Proof Invalid (S.fromList [makeINF' ([(pApp ("Cat") [vt ("x")])]) ([(pApp ("Animal") [vt ("x")])])])]++proofTest1 :: Test+proofTest1 = myTest "Chiuo0 - proof test 1" proof1 (runProver' Nothing (loadKB sentences >> theoremKB (pApp "Kills" [fApp "Jack" [], fApp "Tuna" []] :: TFormula)))++inf' :: (Negatable lit, Ord lit) => [lit] -> [lit] -> ImplicativeForm lit+inf' l1 l2 = INF (S.fromList l1) (S.fromList l2)++proof1 :: (Bool, SetOfSupport TFormula V TTerm)+proof1 = (False,+          (S.fromList+           [(makeINF' ([(pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])]) ([]),fromList []),+            (makeINF' ([]) ([(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []])]),fromList []),+            (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("AnimalLover") [fApp ("Curiosity") []])]) ([]),fromList []),+            (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Dog") [vt ("y2")]),(pApp ("Owns") [fApp ("Curiosity") [],vt ("y")])]) ([]),fromList []),+            (makeINF' ([(pApp ("AnimalLover") [fApp ("Curiosity") []]),(pApp ("Cat") [fApp ("Tuna") []])]) ([]),fromList []),+            (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Curiosity") [],vt ("y")])]) ([]),fromList []),+            (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Dog") [vt ("y2")]),(pApp ("Owns") [fApp ("Curiosity") [],vt ("y")])]) ([]),fromList []),+            (makeINF' ([(pApp ("AnimalLover") [fApp ("Curiosity") []])]) ([]),fromList []),+            (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Curiosity") [],vt ("y")])]) ([]),fromList []),+            (makeINF' ([(pApp ("Dog") [vt ("y2")]),(pApp ("Owns") [fApp ("Curiosity") [],vt ("y")])]) ([]),fromList []),+            (makeINF' ([(pApp ("Owns") [fApp ("Curiosity") [],vt ("y")])]) ([]),fromList [])]))++proofTest2 :: Test+proofTest2 = myTest "Chiuo0 - proof test 2" proof2 (runProver' Nothing (loadKB sentences >> theoremKB conjecture))+    where+      conjecture :: TFormula+      conjecture = (pApp "Kills" [fApp "Curiosity" [], fApp (Fn "Tuna") []])++proof2 :: (Bool, SetOfSupport TFormula V TTerm)+proof2 = (True,+          S.fromList+          [(makeINF' ([]) ([]),fromList []),+           (makeINF' ([]) ([(pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])]),fromList []),+           (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []])]) ([]),fromList []),+           (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("AnimalLover") [fApp ("Jack") []])]) ([]),fromList []),+           (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Dog") [vt ("y2")])]) ([]),fromList []),+           (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Dog") [vt ("y2")]),(pApp ("Owns") [fApp ("Jack") [],vt ("y")])]) ([]),fromList []),+           (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Jack") [],vt ("y")])]) ([]),fromList []),+           (makeINF' ([(pApp ("AnimalLover") [fApp ("Jack") []])]) ([]),fromList []),+           (makeINF' ([(pApp ("AnimalLover") [fApp ("Jack") []]),(pApp ("Cat") [fApp ("Tuna") []])]) ([]),fromList []),+           (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []])]) ([]),fromList []),+           (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Dog") [vt ("y2")])]) ([]),fromList []),+           (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Dog") [vt ("y2")]),(pApp ("Owns") [fApp ("Jack") [],vt ("y")])]) ([]),fromList []),+           (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Jack") [],vt ("y")])]) ([]),fromList []),+           (makeINF' ([(pApp ("Dog") [vt ("y2")]),(pApp ("Owns") [fApp ("Jack") [],vt ("y")])]) ([]),fromList []),+           (makeINF' ([(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []])]) ([]),fromList [])])++testProof :: MonadIO m => String -> (TFormula, Bool, (S.Set (ImplicativeForm TFormula))) -> ProverT (ImplicativeForm TFormula) (SkolemT V TTerm m) ()+testProof label (question, expectedAnswer, expectedProof) =+    theoremKB question >>= \ (actualFlag, actualProof) ->+    let actual' = (actualFlag, S.map fst actualProof) in+    if actual' /= (expectedAnswer, expectedProof)+    then error ("\n Expected:\n  " ++ show (expectedAnswer, expectedProof) +++                "\n Actual:\n  " ++ show actual')+    else liftIO (putStrLn (label ++ " ok"))++loadCmd :: Monad m => ProverT (ImplicativeForm TFormula) (SkolemT V TTerm m) [Proof TFormula]+loadCmd = loadKB sentences++sentences :: [TFormula]+sentences = [exists "x" ((pApp "Dog" [vt "x"]) .&. (pApp "Owns" [fApp "Jack" [], vt "x"])),+             for_all "x" (((exists "y" (pApp "Dog" [vt "y"])) .&. (pApp "Owns" [vt "x", vt "y"])) .=>. (pApp "AnimalLover" [vt "x"])),+             for_all "x" ((pApp "AnimalLover" [vt "x"]) .=>. (for_all "y" ((pApp "Animal" [vt "y"]) .=>. ((.~.) (pApp "Kills" [vt "x", vt "y"]))))),+             (pApp "Kills" [fApp "Jack" [], fApp "Tuna" []]) .|. (pApp "Kills" [fApp "Curiosity" [], fApp "Tuna" []]),+             pApp "Cat" [fApp "Tuna" []],+             for_all "x" ((pApp "Cat" [vt "x"]) .=>. (pApp "Animal" [vt "x"]))]
+ Data/Logic/Tests/Common.hs view
@@ -0,0 +1,277 @@+-- |Types to use for creating test cases.  These are used in the Logic+-- package test cases, and are exported for use in its clients.+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-}+{-# OPTIONS -Wwarn #-}+module Data.Logic.Tests.Common+    ( myTest+      -- * Formula parameter types+    , V(..)+    , Pr(..)+    , AtomicFunction(..)+    , TFormula+    , TAtom+    , TTerm+    , TTestFormula+    , prettyV+    , prettyP+    , prettyF+      -- * Test case types+    , TestFormula(..)+    , Expected(..)+    , doTest+    , TestProof(..)+    , TTestProof+    , ProofExpected(..)+    , doProof+    ) where++import Control.Monad.Reader (MonadPlus(..), msum)+import Data.Boolean.SatSolver (CNF)+import Data.Char (isDigit)+import Data.Generics (Data, Typeable, listify)+import Data.Logic.Classes.Arity (Arity(arity))+import Data.Logic.Classes.ClauseNormalForm (ClauseNormalFormula(satisfiable))+import Data.Logic.Classes.Constants (Constants(..))+import Data.Logic.Classes.Equals (AtomEq)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula, convertFOF)+import Data.Logic.Classes.Literal (Literal)+import Data.Logic.Classes.Skolem (Skolem(..))+import Data.Logic.Classes.Term (Term(vt, fApp, foldTerm))+import Data.Logic.Classes.Variable (Variable(..))+import Data.Logic.Harrison.Normal (trivial)+import Data.Logic.Harrison.Skolem (skolemNormalForm, runSkolem, pnf, nnf, simplify)+import qualified Data.Logic.Instances.Chiou as C+import Data.Logic.Instances.PropLogic (plSat)+import qualified Data.Logic.Instances.SatSolver as SS+import Data.Logic.KnowledgeBase (WithId, runProver', Proof, loadKB, theoremKB, getKB)+import Data.Logic.Normal.Clause (clauseNormalForm)+import Data.Logic.Normal.Implicative (ImplicativeForm, runNormal, runNormalT)+import Data.Logic.Resolution (SetOfSupport)+import qualified Data.Logic.Types.FirstOrder as P+import qualified Data.Set as S+import Data.String (IsString(fromString))++--import PropLogic (PropForm)++import Test.HUnit+import Text.PrettyPrint (Doc, text)++myTest :: (Show a, Eq a) => String -> a -> a -> Test+myTest label expected input =+    TestLabel label $ TestCase (assertEqual label expected input)++newtype V = V String deriving (Eq, Ord, Data, Typeable)++instance IsString V where+    fromString = V++instance Show V where+    show (V s) = show s++prettyV :: V -> Doc+prettyV (V s) = text s++instance Variable V where+    prefix p (V s) = V (p ++ s)+    variant x@(V s) xs = if S.member x xs then variant (V (next s)) xs else x+    prettyVariable (V s) = text s++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)++-- |A newtype for the Primitive Predicate parameter.+data Pr+    = Pr String+    | T+    | F+    | Equals+    deriving (Eq, Ord, Data, Typeable)++instance IsString Pr where+    fromString = Pr++instance Constants Pr where+    fromBool True = T+    fromBool False = F++instance Arity Pr where+    arity (Pr _) = Nothing+    arity T = Just 0+    arity F = Just 0+    arity Equals = Just 2++instance Show Pr where+    show T = "fromBool True"+    show F = "fromBool False"+    show Equals = ".=."+    show (Pr s) = show s            -- Because Pr is an instance of IsString++prettyP :: Pr -> Doc+prettyP T = text "True"+prettyP F = text "False"+prettyP Equals = text ".=."+prettyP (Pr s) = text s++data AtomicFunction+    = Fn String+    | Skolem Int+    deriving (Eq, Ord, Data, Typeable)++instance Skolem AtomicFunction where+    toSkolem = Skolem+    fromSkolem (Skolem n) = Just n+    fromSkolem _ = Nothing++instance IsString AtomicFunction where+    fromString = Fn++instance Show AtomicFunction where+    show (Fn s) = show s+    show (Skolem n) = "toSkolem " ++ show n++prettyF :: AtomicFunction -> Doc+prettyF (Fn s) = text s+prettyF (Skolem n) = text ("sK" ++ show n)++type TFormula = P.Formula V Pr AtomicFunction+type TAtom = P.Predicate Pr TTerm+type TTerm = P.PTerm V AtomicFunction++-- |This allows you to use an expression that returns the Doc type in a+-- unit test, such as prettyFirstOrder.+instance Eq Doc where+    a == b = show a == show b++data (formula ~ TFormula, atom ~ TAtom, v ~ V) => TestFormula formula atom v+    = TestFormula+      { formula :: formula+      , name :: String+      , expected :: [Expected formula atom v]+      } -- deriving (Data, Typeable)++-- |Some values that we might expect after transforming the formula.+data (FirstOrderFormula formula atom v, formula ~ TFormula, atom ~ TAtom, v ~ V) => Expected formula atom v+    = FirstOrderFormula formula+    | SimplifiedForm formula+    | NegationNormalForm formula+    | PrenexNormalForm formula+    | SkolemNormalForm formula+    | SkolemNumbers (S.Set Int)+    | ClauseNormalForm (S.Set (S.Set formula))+    | TrivialClauses [(Bool, (S.Set formula))]+    | ConvertToChiou (C.Sentence V Pr AtomicFunction)+    | ChiouKB1 (Proof formula)+    | PropLogicSat Bool+    | SatSolverCNF CNF+    | SatSolverSat Bool+    -- deriving (Data, Typeable)++deriving instance Show (C.Sentence V Pr AtomicFunction)+deriving instance Show (C.CTerm V AtomicFunction)++type TTestFormula = TestFormula TFormula TAtom V++doTest :: TTestFormula -> Test+doTest f =+    TestLabel (name f) $ TestList $ +    map doExpected (expected f)+    where+      doExpected (FirstOrderFormula f') =+          myTest (name f ++ " original formula") (p f') (p (formula f))+      doExpected (SimplifiedForm f') =+          myTest (name f ++ " simplified") (p f') (p (simplify (formula f)))+      doExpected (PrenexNormalForm f') =+          myTest (name f ++ " prenex normal form") (p f') (p (pnf (formula f)))+      doExpected (NegationNormalForm f') =+          myTest (name f ++ " negation normal form") (p f') (p (nnf . simplify $ (formula f)))+      doExpected (SkolemNormalForm f') =+          myTest (name f ++ " skolem normal form") (p f') (p (runSkolem (skolemNormalForm (formula f))))+      doExpected (SkolemNumbers f') =+          myTest (name f ++ " skolem numbers") f' (skolemSet (runSkolem (skolemNormalForm (formula f))))+      doExpected (ClauseNormalForm fss) =+          myTest (name f ++ " clause normal form") fss (S.map (S.map p) (runSkolem (clauseNormalForm (formula f))))+      doExpected (TrivialClauses flags) =+          myTest (name f ++ " trivial clauses") flags (map (\ (x :: S.Set TFormula) -> (trivial x, x)) (S.toList (runSkolem (clauseNormalForm (formula f :: TFormula)))))+      doExpected (ConvertToChiou result) =+          -- We need to convert (formula f) to Chiou and see if it matches result.+          let ca :: TAtom -> C.Sentence V Pr AtomicFunction+              -- ca = undefined+              ca (P.Apply p ts) = C.Predicate p (map ct ts)+              ca (P.Equal t1 t2) = C.Equal (ct t1) (ct t2)+              ct :: TTerm -> C.CTerm V AtomicFunction+              ct = foldTerm cv fn+              cv :: V -> C.CTerm V AtomicFunction+              cv = vt+              fn :: AtomicFunction -> [TTerm] -> C.CTerm V AtomicFunction+              fn f ts = fApp f (map ct ts) in+          myTest (name f ++ " converted to Chiou") result (convertFOF ca id (formula f) :: C.Sentence V Pr AtomicFunction)+      doExpected (ChiouKB1 result) =+          myTest (name f ++ " Chiou KB") result (runProver' Nothing (loadKB [formula f] >>= return . head))+      doExpected (PropLogicSat result) =+          myTest (name f ++ " PropLogic.satisfiable") result (runSkolem (plSat (formula f)))+      doExpected (SatSolverCNF result) =+          myTest (name f ++ " SatSolver CNF") (norm result) (runNormal (SS.toCNF (formula f)))+      doExpected (SatSolverSat result) =+          myTest (name f ++ " SatSolver CNF") result (null (runNormalT (SS.toCNF (formula f) >>= satisfiable)))+      p = id++      norm = map S.toList . S.toList . S.fromList . map S.fromList++skolemSet :: forall formula atom term v p f. (FirstOrderFormula formula atom v, AtomEq atom p term, Term term v f, Data formula) => formula -> S.Set Int+skolemSet =+    foldr ins S.empty . skolemList+    where+      ins :: f -> S.Set Int -> S.Set Int+      ins f s = case fromSkolem f of+                  Just n -> S.insert n s+                  Nothing -> s+      skolemList :: (FirstOrderFormula formula atom v, AtomEq atom p term, Term term v f, Data f, Typeable f, Data formula) => formula -> [f]+      skolemList inf = gFind inf :: (Typeable f => [f])++-- | @gFind a@ will extract any elements of type @b@ from+-- @a@'s structure in accordance with the MonadPlus+-- 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)++data TestProof formula term v+    = TestProof+      { proofName :: String+      , proofKnowledge :: (String, [formula])+      , conjecture :: formula+      , proofExpected :: [ProofExpected formula v term]+      } deriving (Data, Typeable)++type TTestProof = TestProof TFormula TTerm V++data ProofExpected formula v term+    = ChiouResult (Bool, SetOfSupport formula v term)+    | ChiouKB (S.Set (WithId (ImplicativeForm formula)))+    deriving (Data, Typeable)++doProof :: forall formula atom term v p f. (FirstOrderFormula formula atom v,+                                            AtomEq atom p term, atom ~ P.Predicate p (P.PTerm v f),+                                            Term term v f, term ~ P.PTerm v f,+                                            Literal formula atom v,+                                            Ord formula, Data formula, Eq term, Show term, Show v, Show formula, Constants p, Eq p, Ord f, Show f) =>+           TestProof formula term v -> Test+doProof p =+    TestLabel (proofName p) $ TestList $+    concatMap doExpected (proofExpected p)+    where+      doExpected :: ProofExpected formula v term -> [Test]+      doExpected (ChiouResult result) =+          [myTest (proofName p ++ " with " ++ fst (proofKnowledge p) ++ " using Chiou prover")+                  result+                  (runProver' Nothing (loadKB kb >> theoremKB c))]+      doExpected (ChiouKB result) =+          [myTest (proofName p ++ " with " ++ fst (proofKnowledge p) ++ " Chiou knowledge base")+                  result+                  (runProver' Nothing (loadKB kb >> getKB))]+      kb = snd (proofKnowledge p) :: [formula]+      c = conjecture p :: formula
+ Data/Logic/Tests/Data.hs view
@@ -0,0 +1,1066 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, MonoLocalBinds, NoMonomorphismRestriction, OverloadedStrings, RankNTypes, ScopedTypeVariables, TypeFamilies  #-}+{-# OPTIONS -fno-warn-name-shadowing -fno-warn-missing-signatures #-}+module Data.Logic.Tests.Data+    ( tests+    , allFormulas+    , proofs+{-+    , formulas+    , animalKB+    , animalConjectures+    , chang43KB+    , chang43Conjecture+    , chang43ConjectureRenamed+-}+    ) where++import Data.Boolean.SatSolver (Literal(..))+import Data.Generics (Data, Typeable)+import Data.Logic.Classes.Combine (Combinable(..))+import Data.Logic.Classes.Constants (Constants(..))+import Data.Logic.Classes.Equals (AtomEq, (.=.), pApp, pApp2)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), for_all', exists')+import Data.Logic.Classes.Negate ((.~.))+import Data.Logic.Classes.Term (Term(..))+import Data.Logic.Classes.Skolem (Skolem(toSkolem))+import Data.Logic.Classes.Negate (Negatable(..))+import qualified Data.Logic.Classes.Literal as N+import qualified Data.Logic.Instances.Chiou as C+import Data.Logic.KnowledgeBase (WithId(WithId, wiItem, wiIdent), Proof(..), ProofResult(..))+import Data.Logic.Normal.Implicative (ImplicativeForm(INF), makeINF')+import Data.Logic.Tests.Common (TestFormula(..), TestProof(..), Expected(..), ProofExpected(..), doTest, doProof,+                                TFormula, TAtom, TTerm, V, Pr, AtomicFunction, TTestFormula, TTestProof)+import Data.Logic.Types.FirstOrder (Predicate(..), PTerm(..))+import Data.Map (fromList)+import qualified Data.Set as S+import Data.String (IsString)+import Test.HUnit++{-+:m +Data.Logic.Test+:m +Data.Logic.Types.FirstOrder+:m +Data.Set+runNormal (clauseNormalForm (true :: Formula V Pr AtomicFunction)) :: Set (Set (Formula V Pr AtomicFunction))+runNormal (skolemNormalForm (true :: Formula V Pr AtomicFunction)) :: Formula V Pr AtomicFunction+:m +Data.Logic.Normal.Prenex+prenexNormalForm true :: Formula V Pr AtomicFunction+:m +Data.Logic.Normal.Skolem+:m +Data.Logic.Normal.Negation+-}++tests :: [TTestFormula] -> [TTestProof] -> Test+tests fs ps =+    TestLabel "Test.Data" $ TestList (map doTest fs ++ map doProof ps)++allFormulas :: [TTestFormula]+allFormulas = (formulas +++               concatMap snd [animalKB, chang43KB] +++               animalConjectures +++               [chang43Conjecture, chang43ConjectureRenamed])++formulas :: [TTestFormula]+formulas =+    let n = (.~.)+        p = pApp "p"+        q = pApp "q"+        r = pApp "r"+        s = pApp "s"+        t = pApp "t"+        p0 = p []+        q0 = q []+        r0 = r []+        s0 = s []+        t0 = t []+        (x, y, z, u, v, w) = (vt "x" :: TTerm, vt "y" :: TTerm, vt "z" :: TTerm, vt "u" :: TTerm, vt "v" :: TTerm, vt "w" :: TTerm)+        z2 = vt "z2" :: TTerm in+    +    [ +      TestFormula+      { formula = p0 .|. q0 .&. r0 .|. n s0 .&. n t0+      , name = "operator precedence"+      , expected = [ FirstOrderFormula (p0 .|. (q0 .&. r0) .|. ((n s0) .&. (n t0))) ] }+    , TestFormula+      { formula = pApp (fromBool True) []+      , name = "True"+      , expected = [ClauseNormalForm  (toSS [])] }+    , TestFormula+      { formula = pApp (fromBool False) []+      , name = "False"+      , expected = [ClauseNormalForm  (toSS [[]])] }+    , TestFormula+      { formula = pApp "p" []+      , name = "p"+      , expected = [ClauseNormalForm  (toSS [[pApp "p" []]])] }+    , let p = pApp "p" [] in+      TestFormula+      { formula = p .&. ((.~.) (p))+      , name = "p&~p"+      , expected = [ PrenexNormalForm ((pApp ("p") []) .&. (((.~.) (pApp ("p") []))))+                   , ClauseNormalForm (toSS [[(p)], [((.~.) (p))]])+                   ] }+    , TestFormula+      { formula = pApp "p" [vt "x"]+      , name = "p[x]"+      , expected = [ClauseNormalForm  (toSS [[pApp "p" [x]]])] }+    , let f = pApp "f"+          q = pApp "q" in+      TestFormula+      { name = "iff"+      , formula = for_all "x" (for_all "y" (q [x, y] .<=>. for_all "z" (f [z, x] .<=>. f [z, y])))+      , expected = [ PrenexNormalForm+                     (for_all "x"+                      (for_all "y"+                       (for_all "z"+                        (exists "z2"+                         (((((q [x,y])) .&.+                            ((((((f [z,x])) .&.+                                ((f [z,y])))) .|.+                              (((((.~.) (f [z,x]))) .&.+                                (((.~.) (f [z,y]))))))))) .|.+                          (((((.~.) (q [x,y]))) .&.+                            ((((((f [z2,x])) .&.+                                (((.~.) (f [z2,y]))))) .|.+                              (((((.~.) (f [z2,x]))) .&.+                                ((f [z2,y])))))))))))))+                   , ClauseNormalForm +                     (toSS [[(pApp2 ("f") (vt ("z")) (vt ("x"))),+                             (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("x"))),+                             (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("y"))),+                             ((.~.) (pApp2 ("f") (vt ("z")) (vt ("y"))))],+                            [(pApp2 ("f") (vt ("z")) (vt ("x"))),+                             ((.~.) (pApp2 ("f") (vt ("z")) (vt ("y")))),+                             ((.~.) (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("x")))),+                             ((.~.) (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("y"))))],+                            [(pApp2 ("f") (vt ("z")) (vt ("x"))),+                             ((.~.) (pApp2 ("f") (vt ("z")) (vt ("y")))),+                             ((.~.) (pApp2 ("q") (vt ("x")) (vt ("y"))))],+                            [(pApp2 ("f") (vt ("z")) (vt ("y"))),+                             (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("x"))),+                             (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("y"))),+                             ((.~.) (pApp2 ("f") (vt ("z")) (vt ("x"))))],+                            [(pApp2 ("f") (vt ("z")) (vt ("y"))),+                             ((.~.) (pApp2 ("f") (vt ("z")) (vt ("x")))),+                             ((.~.) (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("x")))),+                             ((.~.) (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("y"))))],+                            [(pApp2 ("f") (vt ("z")) (vt ("y"))),+                             ((.~.) (pApp2 ("f") (vt ("z")) (vt ("x")))),+                             ((.~.) (pApp2 ("q") (vt ("x")) (vt ("y"))))],+                            [(pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("x"))),+                             (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("y"))),+                             (pApp2 ("q") (vt ("x")) (vt ("y")))],+                            [(pApp2 ("q") (vt ("x")) (vt ("y"))),+                             ((.~.) (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("x")))),+                             ((.~.) (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("y"))))]])+                   ]+      }+    , TestFormula+      { name = "move quantifiers out"+      , formula = (for_all "x" (pApp "p" [x]) .&. (pApp "q" [x]))+      , expected = [PrenexNormalForm (for_all "x2" ((pApp "p" [vt ("x2")]) .&. ((pApp "q" [vt ("x")]))))]+      }+    , TestFormula+      { name = "skolemize2"+      , formula = exists "x" (for_all "y" (pApp "loves" [x, y]))+      , expected = [SkolemNormalForm (pApp ("loves") [fApp (toSkolem 1) [],y])]+      }+    , TestFormula+      { name = "skolemize3"+      , formula = for_all "y" (exists "x" (pApp "loves" [x, y]))+      , expected = [SkolemNormalForm (pApp ("loves") [fApp (toSkolem 1) [y],y])]+      }+    , TestFormula+      { formula = exists "x" (for_all' ["y", "z"]+                              (exists "u"+                               (for_all "v"+                                (exists "w"+                                 (pApp "P" [x, y, z, u, v, w])))))+      , name = "chang example 4.1"+      , expected = [ SkolemNormalForm (pApp "P" [fApp (toSkolem 1) [],+                                                 vt ("y"),+                                                 vt ("z"),+                                                 fApp (toSkolem 2) [vt ("y"),vt ("z")],+                                                 vt ("v"),+                                                 fApp (toSkolem 3) [vt ("v"), vt ("y"),vt ("z")]]) ]+      }+    , TestFormula+      { name = "chang example 4.2"+      -- ∀x ∃y∃z ~P(x,y) & Q(x,z) | R(x,y,z)+      , formula = for_all "x" (exists' ["y", "z"] (((((.~.) (pApp "P" [x, y])) .&. pApp "Q" [x, z]) .|. pApp "R" [x, y, z])))+      -- ∀x ~P(x,Sk1[x]) | R(x,Sk1[x],Sk2[x]) & Q(x,Sk2[x]) | R(x,Sk1[x],Sk2[x])+      , expected = [ SkolemNormalForm+                     ((((.~.) (pApp ("P") [vt ("x"),vt ("y")])) .&.+                       ((pApp ("Q") [vt ("x"),vt ("z")]))) .|.+                      ((pApp ("R") [vt ("x"),vt ("y"),vt ("z")])))+                   , ClauseNormalForm+                     (toSS +                      [[((.~.) (pApp ("P") [vt ("x"),vt ("y")])),+                       (pApp ("R") [vt ("x"),vt ("y"),vt ("z")])],+                      [(pApp ("Q") [vt ("x"),vt ("z")]),+                       (pApp ("R") [vt ("x"),vt ("y"),vt ("z")])]]) ]+      }+    , TestFormula+      { formula = n p0 .|. q0 .&. p0 .|. r0 .&. n q0 .&. n r0+      , name = "chang 7.2.1a - unsat"+      , expected = [ SatSolverSat False ] }+    , TestFormula+      { formula = p0 .|. q0 .|. r0 .&. n p0 .&. n q0 .&. n r0 .|. s0 .&. n s0+      , name = "chang 7.2.1b - unsat"+      , expected = [ SatSolverSat False ] }+    , TestFormula+      { formula = p0 .|. q0 .&. q0 .|. r0 .&. r0 .|. s0 .&. n r0 .|. n p0 .&. n s0 .|. n q0 .&. n q0 .|. n r0+      , name = "chang 7.2.1c - unsat"+      , expected = [ SatSolverSat False ] }+    , let q = pApp "q"+          f = pApp "f"+          sk1 = f [fApp (toSkolem 1) [x,x,y,z],y]+          sk2 = f [fApp (toSkolem 1) [x,x,y,z],x] in+      TestFormula+      { name = "distribute bug test"+      , formula = ((((.~.) (q [x,y])) .|.+                    ((((.~.) (sk2)) .|. (sk1)) .&.+                     (((.~.) (sk1)) .|. (sk2)))) .&.+                   ((((sk2) .&.+                      ((.~.) (sk1))) .|. ((sk1) .&.+                      ((.~.) (sk2)))) .|. (q [x,y])))+      , expected = [ClauseNormalForm+                    (toSS+                     [[sk2,sk1,pApp ("q") [x,y]],+                      [sk2,((.~.) (sk1)),((.~.) (q [x,y]))],+                      [sk1,((.~.) (sk2)),((.~.) (q [x,y]))],+                      [q [x,y], ((.~.) sk2),((.~.) sk1)]])]+      }+    , let x = vt "x" :: TTerm+          y = vt "y" :: TTerm+          x' = vt "x" :: C.CTerm V AtomicFunction+          y' = vt "y" :: C.CTerm V AtomicFunction in+      TestFormula+      { name = "convert to Chiou 1"+      , formula = exists "x" (x .=. y)+      , expected = [ConvertToChiou (exists "x" (x' .=. y') :: C.Sentence V Pr AtomicFunction)]+      }+    , let s = pApp "s"+          s' = pApp "s"+          x' = vt "x"+          y' = vt "y" in+      TestFormula+      { name = "convert to Chiou 2"+      , formula = s [fApp ("a") [x, y]]+      , expected = [ConvertToChiou (s' [fApp "a" [x', y']])]+      }+    , let s = pApp "s"+          h = pApp "h"+          m = pApp "m"+          s' = pApp "s"+          h' = pApp "h"+          m' = pApp "m"+          x' = vt "x" in+      TestFormula+      { name = "convert to Chiou 3"+      , formula = for_all "x" (((s [x] .=>. h [x]) .&. (h [x] .=>. m [x])) .=>. (s [x] .=>. m [x]))+      , expected = [ConvertToChiou (for_all "x" (((s' [x'] .=>. h' [x']) .&. (h' [x'] .=>. m' [x'])) .=>. (s' [x'] .=>. m' [x'])))]+      }+    , let taller a b = pApp "taller" [a, b]+          wise a = pApp "wise" [a] in+      TestFormula+      { name = "cnf test 1"+      , formula = for_all "y" (for_all "x" (taller y x .|. wise x) .=>. wise y)+      , expected = [ClauseNormalForm+                    (toSS+                     [[(pApp ("wise") [vt ("y")]),+                       ((.~.) (pApp ("taller") [vt ("y"),fApp (toSkolem 1) [vt ("y")]]))],+                      [(pApp ("wise") [vt ("y")]),+                       ((.~.) (pApp ("wise") [fApp (toSkolem 1) [vt ("y")]]))]])]+      }+    , TestFormula+      { name = "cnf test 2"+      , formula = ((.~.) (exists "x" (pApp "s" [x] .&. pApp "q" [x])))+      , expected = [ ClauseNormalForm (toSS +                                       [[((.~.) (pApp ("q") [vt ("x")])),+                                         ((.~.) (pApp ("s") [vt ("x")]))]])+                   , PrenexNormalForm (for_all "x"+                                       (((.~.) (pApp ("s") [vt ("x")])) .|.+                                        (((.~.) (pApp ("q") [vt ("x")])))))+                                     {- [[((.~.) (pApp "s" [vt "x"])),+                                        ((.~.) (pApp "q" [vt "x"]))]] -}+                   ]+      }+    , TestFormula+      { name = "cnf test 3"+      , formula = (for_all "x" (p [x] .=>. (q [x] .|. r [x])))+      , expected = [ClauseNormalForm (toSS [[((.~.) (pApp "p" [vt "x"])),(pApp "q" [vt "x"]),(pApp "r" [vt "x"])]])]+      }+    , TestFormula+      { name = "cnf test 4"+      , formula = ((.~.) (exists "x" (p [x] .=>. exists "y" (q [y]))))+      , expected = [ClauseNormalForm (toSS [[(pApp "p" [vt "x"])],[((.~.) (pApp "q" [vt "y"]))]])]+      }+    , TestFormula+      { name = "cnf test 5"+      , formula = (for_all "x" (q [x] .|. r [x] .=>. s [x]))+      , expected = [ClauseNormalForm (toSS [[((.~.) (pApp "q" [vt "x"])),(pApp "s" [vt "x"])],[((.~.) (pApp "r" [vt "x"])),(pApp "s" [vt "x"])]])]+      }+    , TestFormula+      { name = "cnf test 6"+      , formula = (exists "x" (p0 .=>. pApp "f" [x]))+      , expected = [ClauseNormalForm (toSS [[((.~.) (pApp "p" [])),(pApp "f" [fApp (toSkolem 1) []])]])]+      }+    , let p = pApp "p" []+          f' = pApp "f" [x]+          f = pApp "f" [fApp (toSkolem 1) []] in+      TestFormula+      { name = "cnf test 7"+      , formula = exists "x" (p .<=>. f')+      , expected = [ PrenexNormalForm (exists "x" ((p .&. f') .|. ((((.~.) p) .&. (((.~.) f'))))))+                   , SkolemNormalForm ((p .&. f) .|. (((.~.) p) .&. (((.~.) f))))+                   , TrivialClauses [(False,S.fromList [((.~.) (pApp ("p") [])),(pApp ("f") [fApp (toSkolem 1) []])]),+                                     (False,S.fromList [((.~.) (pApp ("f") [fApp (toSkolem 1) []])),(pApp ("p") [])])]+                   , ClauseNormalForm (toSS [[(f), ((.~.) p)], [p, ((.~.) f)]])]+      }+    , TestFormula+      { name = "cnf test 8"+      , formula = (for_all "z" (exists "y" (for_all "x" (pApp "f" [x, y] .<=>. (pApp "f" [x, z] .&. ((.~.) (pApp "f" [x, x])))))))+      , expected = [ClauseNormalForm +                    (toSS [[((.~.) (pApp "f" [vt "x",fApp (toSkolem 1) [vt "z"]])),(pApp "f" [vt "x",vt "z"])],+                           [((.~.) (pApp "f" [vt "x",fApp (toSkolem 1) [vt "z"]])),((.~.) (pApp "f" [vt "x",vt "x"]))],+                           [((.~.) (pApp "f" [vt "x",vt "z"])),(pApp "f" [vt "x",vt "x"]),(pApp "f" [vt "x",fApp (toSkolem 1) [vt "z"]])]])]+      }+    , let f = pApp "f" +          q = pApp "q"+          (x, y, z) = (vt "x" :: TTerm, vt "y" :: TTerm, vt "z" :: TTerm) in+      TestFormula+      { name = "cnf test 9"+      , formula = (for_all "x" (for_all "x" (for_all "y" (q [x, y] .<=>. for_all "z" (f [z, x] .<=>. f [z, y])))))+      , expected = [ClauseNormalForm+                    (toSS+                     [[(pApp2 ("f") (vt ("z")) (vt ("x"))),+                       (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("x"))),+                       (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("y"))),+                       ((.~.) (pApp2 ("f") (vt ("z")) (vt ("y"))))],+                      [(pApp2 ("f") (vt ("z")) (vt ("x"))),+                       ((.~.) (pApp2 ("f") (vt ("z")) (vt ("y")))),+                       ((.~.) (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("x")))),+                       ((.~.) (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("y"))))],+                      [(pApp2 ("f") (vt ("z")) (vt ("x"))),+                       ((.~.) (pApp2 ("f") (vt ("z")) (vt ("y")))),+                       ((.~.) (pApp2 ("q") (vt ("x")) (vt ("y"))))],+                      [(pApp2 ("f") (vt ("z")) (vt ("y"))),+                       (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("x"))),+                       (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("y"))),((.~.) (pApp2 ("f") (vt ("z")) (vt ("x"))))],+                      [(pApp2 ("f") (vt ("z")) (vt ("y"))),+                       ((.~.) (pApp2 ("f") (vt ("z")) (vt ("x")))),+                       ((.~.) (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("x")))),+                       ((.~.) (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("y"))))],+                      [(pApp2 ("f") (vt ("z")) (vt ("y"))),+                       ((.~.) (pApp2 ("f") (vt ("z")) (vt ("x")))),+                       ((.~.) (pApp2 ("q") (vt ("x")) (vt ("y"))))],+                      [(pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("x"))),+                       (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("y"))),+                       (pApp2 ("q") (vt ("x")) (vt ("y")))],+                      [(pApp2 ("q") (vt ("x")) (vt ("y"))),+                       ((.~.) (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("x")))),+                       ((.~.) (pApp2 ("f") (fApp (toSkolem 1) [vt ("x"),vt ("y")]) (vt ("y"))))]])+                   ]+      }+    , TestFormula+      { name = "cnf test 10"+      , formula = (for_all "x" (exists "y" ((p [x, y] .<=. for_all "x" (exists "z" (q [y, x, z]) .=>. r [y])))))+      , expected = [ClauseNormalForm+                    (toSS +                     [[(pApp ("p") [vt ("x"),fApp (toSkolem 1) [vt ("x")]]),+                       (pApp ("q") [fApp (toSkolem 1) [vt "x"],fApp (toSkolem 2) [vt "x"],fApp (toSkolem 3) [vt "x"]])],+                      [(pApp ("p") [vt ("x"),fApp (toSkolem 1) [vt ("x")]]),+                       ((.~.) (pApp ("r") [fApp (toSkolem 1) [vt "x"]]))]])+                   ]+      }+    , TestFormula+      { name = "cnf test 11"+      , formula = (for_all "x" (for_all "z" (p [x, z] .=>. exists "y" ((.~.) (q [x, y] .|. ((.~.) (r [y, z])))))))+      , expected = [ClauseNormalForm+                    (toSS +                    [[((.~.) (pApp "p" [vt "x",vt "z"])),((.~.) (pApp "q" [vt "x",fApp (toSkolem 1) [vt "x",vt "z"]]))],+                     [((.~.) (pApp "p" [vt "x",vt "z"])),(pApp "r" [fApp (toSkolem 1) [vt "x",vt "z"],vt "z"])]])]+      }+    , TestFormula+      { name = "cnf test 12"+      , formula = ((p0 .=>. q0) .=>. (((.~.) r0) .=>. (s0 .&. t0)))+      , expected = [ClauseNormalForm+                    (toSS+                    [[(pApp "p" []),(pApp "r" []),(pApp "s" [])],+                     [((.~.) (pApp "q" [])),(pApp "r" []),(pApp "s" [])],+                     [(pApp "p" []),(pApp "r" []),(pApp "t" [])],+                     [((.~.) (pApp "q" [])),(pApp "r" []),(pApp "t" [])]])]+      }+    , let p = pApp "p" []+          true = pApp (fromBool True) []+          false = pApp (fromBool False) [] in+      TestFormula+      { name = "psimplify 50"+      , formula = true .=>. (p .<=>. (p .<=>. false))+      , expected = [ SimplifiedForm (p .<=>. (.~.) p) ] }+    , let true = pApp (fromBool True) []+          false = pApp (fromBool False) [] in+      TestFormula+      { name = "psimplify 51"+      , formula = (((pApp "x" [] .=>. pApp "y" []) .=>. true) .|. false)+      , expected = [ SimplifiedForm (pApp (fromBool True) []) ] }+    , let false = pApp (fromBool False) []+          q = pApp "q" [] in+      TestFormula+      { name = "simplify 140.3"+      , formula = (for_all "x"+                   (for_all "y"+                    (pApp "p" [vt "x"] .|. (pApp "p" [vt "y"] .&. false))) .=>.+                   (exists "z" q))+      , expected = [ SimplifiedForm ((for_all "x" (pApp "p" [vt "x"])) .=>.+                                        (pApp "q" [])) ] }+    , TestFormula+      { name = "nnf 141.1"+      , formula = ((for_all "x" (pApp "p" [vt "x"])) .=>. ((exists "y" (pApp "q" [vt "y"])) .<=>. (exists "z" (pApp "p" [vt "z"] .&. pApp "q" [vt "z"]))))+      , expected = [ NegationNormalForm +                     ((exists "x" ((.~.) (pApp "p" [vt "x"]))) .|.+                      ((((exists "y" (pApp "q" [vt "y"])) .&. ((exists "z" ((pApp "p" [vt "z"]) .&. ((pApp "q" [vt "z"])))))) .|.+                        (((for_all "y" ((.~.) (pApp "q" [vt "y"]))) .&.+                          ((for_all "z" (((.~.) (pApp "p" [vt "z"])) .|. (((.~.) (pApp "q" [vt "z"]))))))))))) ] }+    , TestFormula+      { name = "pnf 144.1"+      , formula = (for_all "x" (pApp "p" [vt "x"] .|. pApp "r" [vt "y"]) .=>.+                   (exists "y" (exists "z" (pApp "q" [vt "y"] .|. ((.~.) (exists "z" (pApp "p" [vt "z"] .&. pApp "q" [vt "z"])))))))+      , expected = [ PrenexNormalForm +                     (exists "x" +                      (for_all "z"+                       ((((.~.) (pApp "p" [vt "x"])) .&. (((.~.) (pApp "r" [vt "y"])))) .|.+                        (((pApp "q" [vt "x"]) .|. ((((.~.) (pApp "p" [vt "z"])) .|. (((.~.) (pApp "q" [vt "z"])))))))))) ] }+    , let (x, y, u, v) = (vt "x" :: TTerm, vt "y" :: TTerm, vt "u" :: TTerm, vt "v" :: TTerm)+          fv = fApp (toSkolem 2) [u,x]+          fy = fApp (toSkolem 1) [x] in+      TestFormula+      { name = "snf 150.1"+      , formula = (exists "y" (pApp "<" [x, y] .=>. for_all "u" (exists "v" (pApp "<" [fApp "*" [x, u], fApp "*" [y, v]]))))+      , expected = [ SkolemNormalForm (((.~.) (pApp "<" [x, fy])) .|. pApp "<" [fApp "*" [x, u], fApp "*" [fy, fv]]) ] }+    , let p x = pApp "p" [x]+          q x = pApp "q" [x]+          (x, y, z) = (vt "x" :: TTerm, vt "y" :: TTerm, vt "z" :: TTerm) in+      TestFormula+      { name = "snf 150.2"+      , formula = (for_all "x" (p x .=>. (exists "y" (exists "z" (q y .|. (.~.) (exists "z" (p z .&. (q z))))))))+      , expected = [ SkolemNormalForm (((.~.) (p x)) .|. (q (fApp (toSkolem 1) []) .|. (((.~.) (p z)) .|. ((.~.) (q z))))) ] }+    ]++animalKB :: (String, [TTestFormula])+animalKB =+    let x = vt "x"+        y = vt "y"+        dog = pApp "Dog"+        cat = pApp "Cat"+        owns = pApp "Owns"+        kills = pApp "Kills"+        animal = pApp "Animal"+        animalLover = pApp "AnimalLover"+        jack = fApp "Jack" []+        tuna = fApp "Tuna" []+        curiosity = fApp "Curiosity" [] in+    ("animal"+    , [ TestFormula+       { formula = exists "x" (dog [x] .&. owns [jack, x]) -- [[Pos 1],[Pos 2]]+       , name = "jack owns a dog"+       , expected = [ClauseNormalForm (toSS [[(pApp "Dog" [fApp (toSkolem 1) []])],[(pApp "Owns" [fApp "Jack" [],fApp (toSkolem 1) []])]])]+       -- owns(jack,sK0)+       -- dog (SK0)+                   }+     , TestFormula+       { formula = for_all "x" ((exists "y" (dog [y] .&. (owns [x, y]))) .=>. (animalLover [x])) -- [[Neg 1,Neg 2,Pos 3]]+       , name = "dog owners are animal lovers"+       , expected = [ PrenexNormalForm (for_all "x" (for_all "y" ((((.~.) (pApp "Dog" [vt "y"])) .|.+                                                                           (((.~.) (pApp "Owns" [vt "x",vt "y"])))) .|.+                                                                          ((pApp "AnimalLover" [vt "x"])))))+                    , ClauseNormalForm (toSS [[((.~.) (pApp "Dog" [vt "y"])),((.~.) (pApp "Owns" [vt "x",vt "y"])),(pApp "AnimalLover" [vt "x"])]]) ]+       -- animalLover(X0) | ~owns(X0,sK1(X0)) | ~dog(sK1(X0))+       }+     , TestFormula+       { formula = for_all "x" (animalLover [x] .=>. (for_all "y" ((animal [y]) .=>. ((.~.) (kills [x, y]))))) -- [[Neg 3,Neg 4,Neg 5]]+       , name = "animal lovers don't kill animals"+       , expected = [ClauseNormalForm  (toSS [[((.~.) (pApp "AnimalLover" [vt "x"])),((.~.) (pApp "Animal" [vt "y"])),((.~.) (pApp "Kills" [vt "x",vt "y"]))]])]+       -- ~kills(X0,X2) | ~animal(X2) | ~animalLover(sK2(X0))+       }+     , TestFormula+       { formula = (kills [jack, tuna]) .|. (kills [curiosity, tuna]) -- [[Pos 5,Pos 5]]+       , name = "Either jack or curiosity kills tuna"+       , expected = [ClauseNormalForm  (toSS [[(pApp "Kills" [fApp "Jack" [],fApp "Tuna" []]),(pApp "Kills" [fApp "Curiosity" [],fApp "Tuna" []])]])]+       -- kills(curiosity,tuna) | kills(jack,tuna)+       }+     , TestFormula+       { formula = cat [tuna] -- [[Pos 6]]+       , name = "tuna is a cat"+       , expected = [ClauseNormalForm  (toSS [[(pApp "Cat" [fApp "Tuna" []])]])]+       -- cat(tuna)+       }+     , TestFormula+       { formula = for_all "x" ((cat [x]) .=>. (animal [x])) -- [[Neg 6,Pos 4]]+       , name = "a cat is an animal"+       , expected = [ClauseNormalForm  (toSS [[((.~.) (pApp "Cat" [vt "x"])),(pApp "Animal" [vt "x"])]])]+       -- animal(X0) | ~cat(X0)+       }+     ])++animalConjectures :: [TTestFormula]+animalConjectures =+    let kills = pApp "Kills"+        jack = fApp "Jack" []+        tuna = fApp "Tuna" []+        curiosity = fApp "Curiosity" [] in++    map (withKB animalKB) $+     [ TestFormula+       { formula = kills [jack, tuna]             -- False+       , name = "jack kills tuna"+       , expected =+           [ FirstOrderFormula ((.~.) (((exists "x" ((pApp "Dog" [vt ("x")]) .&. ((pApp "Owns" [fApp ("Jack") [],vt ("x")])))) .&.+                                        (((for_all "x" ((exists "y" ((pApp "Dog" [vt ("y")]) .&. ((pApp "Owns" [vt ("x"),vt ("y")])))) .=>.+                                                          ((pApp "AnimalLover" [vt ("x")])))) .&.+                                          (((for_all "x" ((pApp "AnimalLover" [vt ("x")]) .=>.+                                                            ((for_all "y" ((pApp "Animal" [vt ("y")]) .=>.+                                                                             (((.~.) (pApp "Kills" [vt ("x"),vt ("y")])))))))) .&.+                                            ((((pApp "Kills" [fApp ("Jack") [],fApp ("Tuna") []]) .|. ((pApp "Kills" [fApp ("Curiosity") [],fApp ("Tuna") []]))) .&.+                                              (((pApp "Cat" [fApp ("Tuna") []]) .&.+                                                ((for_all "x" ((pApp "Cat" [vt ("x")]) .=>.+                                                                 ((pApp "Animal" [vt ("x")])))))))))))))) .=>.+                                       ((pApp "Kills" [fApp ("Jack") [],fApp ("Tuna") []]))))++           , PrenexNormalForm+             (for_all "x"+              (for_all "y"+               (exists "x2"+                ((((pApp ("Dog") [vt ("x2")]) .&.+                   ((pApp ("Owns") [fApp ("Jack") [],vt ("x2")]))) .&.+                  ((((((.~.) (pApp ("Dog") [vt ("y")])) .|.+                      (((.~.) (pApp ("Owns") [vt ("x"),vt ("y")])))) .|.+                     ((pApp ("AnimalLover") [vt ("x")]))) .&.+                    (((((.~.) (pApp ("AnimalLover") [vt ("x")])) .|.+                       ((((.~.) (pApp ("Animal") [vt ("y")])) .|.+                         (((.~.) (pApp ("Kills") [vt ("x"),vt ("y")])))))) .&.+                      ((((pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []]) .|.+                         ((pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []]))) .&.+                        (((pApp ("Cat") [fApp ("Tuna") []]) .&.+                          ((((.~.) (pApp ("Cat") [vt ("x")])) .|.+                            ((pApp ("Animal") [vt ("x")]))))))))))))) .&.+                 (((.~.) (pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])))))))+           , ClauseNormalForm+             (toSS+              [[(pApp ("Animal") [vt ("x")]),+                ((.~.) (pApp ("Cat") [vt ("x")]))],+               [(pApp ("AnimalLover") [vt ("x")]),+                ((.~.) (pApp ("Dog") [vt ("y")])),+                ((.~.) (pApp ("Owns") [vt ("x"),vt ("y")]))],+               [(pApp ("Cat") [fApp ("Tuna") []])],+               [(pApp ("Dog") [fApp (toSkolem 1) []])],+               [(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []]),+                (pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])],+               [(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem 1) []])],+               [((.~.) (pApp ("Animal") [vt ("y")])),+                ((.~.) (pApp ("AnimalLover") [vt ("x")])),+                ((.~.) (pApp ("Kills") [vt ("x"),vt ("y")]))],+               [((.~.) (pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []]))]])+           , ChiouKB1+             (Proof+              Invalid+              (S.fromList +               [makeINF' ([]) ([(pApp ("Cat") [fApp ("Tuna") []])]),+                makeINF' ([]) ([(pApp ("Dog") [fApp (toSkolem 1) []])]),+                makeINF' ([]) ([(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []]),(pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])]),+                makeINF' ([]) ([(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem 1) []])]),+                makeINF' ([(pApp ("Animal") [vt ("y")]),(pApp ("AnimalLover") [vt ("x")]),(pApp ("Kills") [vt ("x"),vt ("y")])]) ([]),+                makeINF' ([(pApp ("Cat") [vt ("x")])]) ([(pApp ("Animal") [vt ("x")])]),+                makeINF' ([(pApp ("Dog") [vt ("y")]),(pApp ("Owns") [vt ("x"),vt ("y")])]) ([(pApp ("AnimalLover") [vt ("x")])]),+                makeINF' ([(pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])]) ([])]))+           ]+       }+     , TestFormula+       { formula = kills [curiosity, tuna]        -- True+       , name = "curiosity kills tuna"+       , expected =+           [ ClauseNormalForm+             (toSS+             [[(pApp "Dog" [fApp (toSkolem 1) []])],+              [(pApp "Owns" [fApp ("Jack") [],fApp (toSkolem 1) []])],+              [((.~.) (pApp "Dog" [vt ("y")])),+               ((.~.) (pApp "Owns" [vt ("x"),vt ("y")])),+               (pApp "AnimalLover" [vt ("x")])],+              [((.~.) (pApp "AnimalLover" [vt ("x")])),+               ((.~.) (pApp "Animal" [vt ("y")])),+               ((.~.) (pApp "Kills" [vt ("x"),vt ("y")]))],+              [(pApp "Kills" [fApp ("Jack") [],fApp ("Tuna") []]),+               (pApp "Kills" [fApp ("Curiosity") [],fApp ("Tuna") []])],+              [(pApp "Cat" [fApp ("Tuna") []])],+              [((.~.) (pApp "Cat" [vt ("x")])),+               (pApp "Animal" [vt ("x")])],+              [((.~.) (pApp "Kills" [fApp "Curiosity" [],fApp "Tuna" []]))]])+           , PropLogicSat True+{-+           , SatSolverCNF [ [Neg 1,Neg 2,Neg 3]    -- animallover(x)|animal(y)|kills(x,y)+                          , [Neg 4,Pos 5]          -- ~cat(x)|animal(x)+                          , [Neg 6,Neg 7,Pos 2]    -- ~dog(y)|~owns(x,y)|animallover(x)+                          , [Neg 8]                -- ~kills(curisity,tuna)+                          , [Pos 8,Pos 11]         -- kills(curiosity,tuna)|kills(jack,tuna)+                          , [Pos 9]                -- cat(tuna)+                          , [Pos 10]               -- owns(jack,sk1)+                          , [Pos 12]               -- dog(sk1)+                          ]+-}+           -- I haven't tried to figure out if this is correct, it+           -- probably is because things are working.+           , SatSolverCNF [[Neg 2,Pos 1],[Neg 3,Neg 11,Neg 12],[Neg 4,Neg 5,Pos 3],[Neg 8],[Pos 6],[Pos 7],[Pos 8,Pos 9],[Pos 10]]+           -- It seems like this should be True.+           , SatSolverSat False+           ]+       }+     ]++socratesKB =+    let x = vt "x"+        socrates x = pApp "Socrates" [x]+        human x = pApp "Human" [x]+        mortal x = pApp "Mortal" [x] in+    ("socrates"+    , [ TestFormula+       { name = "all humans are mortal"+       , formula = for_all "x" (human x .=>. mortal x)+       , expected = [ClauseNormalForm  (toSS [[((.~.) (human x)), mortal x]])] }+     , TestFormula+       { name = "socrates is human"+       , formula = for_all "x" (socrates x .=>. human x)+       , expected = [ClauseNormalForm  (toSS [[(.~.) (socrates x), human x]])] }+     ])++{-+socratesConjectures =+    map (withKB socratesKB)+     [ TestFormula+       { formula = for_all' [V "x"] (socrates x .=>. mortal x)+       , name = "socrates is mortal"+       , expected = [ FirstOrderFormula ((.~.) (((for_all' [V "x"] ((pApp "Human" [vt "x"]) .=>. ((pApp "Mortal" [vt "x"])))) .&.+                                                 ((for_all' [V "x"] ((pApp "Socrates" [vt "x"]) .=>. ((pApp "Human" [vt "x"])))))) .=>.+                                                ((for_all' [V "x"] ((pApp "Socrates" [vt "x"]) .=>. ((pApp "Mortal" [vt "x"])))))))+                    , ClauseNormalForm  [[((.~.) (pApp "Human" [vt "x2"])),(pApp "Mortal" [vt "x2"])],+                                          [((.~.) (pApp "Socrates" [vt "x2"])),(pApp "Human" [vt "x2"])],+                                          [(pApp "Socrates" [fApp (toSkolem 1) [vt "x2",vt "x2"]])],+                                          [((.~.) (pApp "Mortal" [fApp (toSkolem 1) [vt "x2",vt "x2"]]))]]+                    , SatPropLogic True ]+       }+     , TestFormula+       { formula = (.~.) (for_all' [V "x"] (socrates x .=>. mortal x))+       , name = "not (socrates is mortal)"+       , expected = [ SatPropLogic False+                    , FirstOrderFormula ((.~.) (((for_all' [V "x"] ((pApp "Human" [vt "x"]) .=>. ((pApp "Mortal" [vt "x"])))) .&.+                                                 ((for_all' [V "x"] ((pApp "Socrates" [vt "x"]) .=>. ((pApp "Human" [vt "x"])))))) .=>.+                                                (((.~.) (for_all' [V "x"] ((pApp "Socrates" [vt "x"]) .=>. ((pApp "Mortal" [vt "x"]))))))))+                    -- [~human(x) | mortal(x)], [~socrates(Sk1(x,y)) | human(Sk1(x,y))], socrates(Sk1(x,y)), ~mortal(Sk1(x,y))+                    -- ~1 | 2, ~3 | 4, 3, ~5?+                    , ClauseNormalForm [[((.~.) (pApp "Human" [x])), (pApp "Mortal" [x])],+                                         [((.~.) (pApp "Socrates" [fApp (toSkolem 1) [x,y]])), (pApp "Human" [fApp (toSkolem 1) [x,y]])],+                                         [(pApp "Socrates" [fApp (toSkolem 1) [x,y]])], [((.~.) (pApp "Mortal" [fApp (toSkolem 1) [x,y]]))]]+                    , ClauseNormalForm [[((.~.) (pApp "Human" [vt "x2"])), (pApp "Mortal" [vt "x2"])],+                                         [((.~.) (pApp "Socrates" [vt "x2"])), (pApp "Human" [vt "x2"])],+                                         [((.~.) (pApp "Socrates" [vt "x"])), (pApp "Mortal" [vt "x"])]] ]+       }+     ]+-}++chang43KB :: (String, [TTestFormula])+chang43KB = +    let e = fApp "e" []+        (x, y, z, u, v, w) = (vt "x" :: TTerm, vt "y" :: TTerm, vt "z" :: TTerm, vt "u" :: TTerm, vt "v" :: TTerm, vt "w" :: TTerm) in+    ("chang example 4.3"+    , [ TestFormula { name = "closure property"+                    , formula = for_all' ["x", "y"] (exists "z" (pApp "P" [x,y,z]))+                    , expected = [] }+      , TestFormula { name = "associativity property"+                    , formula = for_all' ["x", "y", "z", "u", "v", "w"] (pApp "P" [x, y, u] .&. pApp "P" [y, z, v] .&. pApp "P" [u, z, w] .=>. pApp "P" [x, v, w]) .&.+                                for_all' ["x", "y", "z", "u", "v", "w"] (pApp "P" [x, y, u] .&. pApp "P" [y, z, v] .&. pApp "P" [x, v, w] .=>. pApp "P" [u, z, w])+                    , expected = [] }+      , TestFormula { name = "identity property"+                    , formula = (for_all "x" (pApp "P" [x,e,x])) .&. (for_all "x" (pApp "P" [e,x,x]))+                    , expected = [] }+      , TestFormula { name = "inverse property"+                    , formula = (for_all "x" (pApp "P" [x,fApp "i" [x], e])) .&. (for_all "x" (pApp "P" [fApp "i" [x], x, e]))+                    , expected = [] }+      ])++chang43Conjecture :: TTestFormula+chang43Conjecture =+    let e = (fApp "e" [])+        (x, u, v, w) = (vt "x" :: TTerm, vt "u" :: TTerm, vt "v" :: TTerm, vt "w" :: TTerm) in+    withKB chang43KB $+    TestFormula { name = "G is commutative"+                , formula = for_all "x" (pApp "P" [x, x, e] .=>. (for_all' ["u", "v", "w"] (pApp "P" [u, v, w] .=>. pApp "P" [v, u, w]))) +                , expected =+                    [ FirstOrderFormula +                      ((.~.) (((for_all' ["x","y"] (exists "z" (pApp "P" [vt ("x"),vt ("y"),vt ("z")]))) .&. ((((for_all' ["x","y","z","u","v","w"] ((((pApp "P" [vt ("x"),vt ("y"),vt ("u")]) .&. ((pApp "P" [vt ("y"),vt ("z"),vt ("v")]))) .&. ((pApp "P" [vt ("u"),vt ("z"),vt ("w")]))) .=>. ((pApp "P" [vt ("x"),vt ("v"),vt ("w")])))) .&. ((for_all' ["x","y","z","u","v","w"] ((((pApp "P" [vt ("x"),vt ("y"),vt ("u")]) .&. ((pApp "P" [vt ("y"),vt ("z"),vt ("v")]))) .&. ((pApp "P" [vt ("x"),vt ("v"),vt ("w")]))) .=>. ((pApp "P" [vt ("u"),vt ("z"),vt ("w")])))))) .&. ((((for_all "x" (pApp "P" [vt ("x"),fApp ("e") [],vt ("x")])) .&. ((for_all "x" (pApp "P" [fApp ("e") [],vt ("x"),vt ("x")])))) .&. (((for_all "x" (pApp "P" [vt ("x"),fApp ("i") [vt ("x")],fApp ("e") []])) .&. ((for_all "x" (pApp "P" [fApp ("i") [vt ("x")],vt ("x"),fApp ("e") []])))))))))) .=>. ((for_all "x" ((pApp "P" [vt ("x"),vt ("x"),fApp ("e") []]) .=>. ((for_all' ["u","v","w"] ((pApp "P" [vt ("u"),vt ("v"),vt ("w")]) .=>. ((pApp "P" [vt ("v"),vt ("u"),vt ("w")]))))))))))+                      -- (∀x ∀y ∃z P(x,y,z)) &+                      -- (∀x∀y∀z∀u∀v∀w ~P(x,y,u) | ~P(y,z,v) | ~P(u,z,w) | P(x,v,w)) &+                      -- (∀x∀y∀z∀u∀v∀w ~P(x,y,u) | ~P(y,z,v) | ~P(x,v,w) | P(u,z,w)) &+                      -- (∀x P(x,e,x)) &+                      -- (∀x P(e,x,x)) &+                      -- (∀x P(x,i[x],e)) &+                      -- (∀x P(i[x],x,e)) &+                      -- (∃x P(x,x,e) & (∃u∃v∃w P(u,v,w) & ~P(v,u,w)))+                    , NegationNormalForm+                      (((for_all "x"+                         (for_all "y"+                          (exists "z"+                           (pApp ("P") [vt ("x"),vt ("y"),vt ("z")])))) .&.+                        ((((for_all "x"+                            (for_all "y"+                             (for_all "z"+                              (for_all "u"+                               (for_all "v"+                                (for_all "w"+                                 (((((.~.) (pApp ("P") [vt ("x"),vt ("y"),vt ("u")])) .|.+                                    (((.~.) (pApp ("P") [vt ("y"),vt ("z"),vt ("v")])))) .|.+                                   (((.~.) (pApp ("P") [vt ("u"),vt ("z"),vt ("w")])))) .|.+                                  ((pApp ("P") [vt ("x"),vt ("v"),vt ("w")]))))))))) .&.+                           ((for_all "x"+                             (for_all "y"+                              (for_all "z"+                               (for_all "u"+                                (for_all "v"+                                 (for_all "w"+                                  (((((.~.) (pApp ("P") [vt ("x"),vt ("y"),vt ("u")])) .|.+                                     (((.~.) (pApp ("P") [vt ("y"),vt ("z"),vt ("v")])))) .|.+                                    (((.~.) (pApp ("P") [vt ("x"),vt ("v"),vt ("w")])))) .|.+                                   ((pApp ("P") [vt ("u"),vt ("z"),vt ("w")]))))))))))) .&.+                          ((((for_all "x" (pApp ("P") [vt ("x"),fApp ("e") [],vt ("x")])) .&.+                             ((for_all "x" (pApp ("P") [fApp ("e") [],vt ("x"),vt ("x")])))) .&.+                            (((for_all "x" (pApp ("P") [vt ("x"),fApp ("i") [vt ("x")],fApp ("e") []])) .&.+                              ((for_all "x" (pApp ("P") [fApp ("i") [vt ("x")],vt ("x"),fApp ("e") []])))))))))) .&.+                       ((exists "x"+                         ((pApp ("P") [vt ("x"),vt ("x"),fApp ("e") []]) .&.+                          ((exists "u"+                            (exists "v"+                             (exists "w"+                              ((pApp ("P") [vt ("u"),vt ("v"),vt ("w")]) .&.+                               (((.~.) (pApp ("P") [vt ("v"),vt ("u"),vt ("w")]))))))))))))+                    , PrenexNormalForm+                      (for_all "x"+                       (for_all "y"+                        (for_all "z"+                         (for_all "u"+                          (for_all "v"+                           (for_all "w"+                            (exists "z2"+                             (exists "x2"+                              (exists "u2"+                               (exists "v2"+                                (exists "w2"+                                 (((pApp ("P") [vt ("x"),vt ("y"),vt ("z2")]) .&.+                                   ((((((((.~.) (pApp ("P") [vt ("x"),vt ("y"),vt ("u")])) .|.+                                         (((.~.) (pApp ("P") [vt ("y"),vt ("z"),vt ("v")])))) .|.+                                        (((.~.) (pApp ("P") [vt ("u"),vt ("z"),vt ("w")])))) .|.+                                       ((pApp ("P") [vt ("x"),vt ("v"),vt ("w")]))) .&.+                                      ((((((.~.) (pApp ("P") [vt ("x"),vt ("y"),vt ("u")])) .|.+                                          (((.~.) (pApp ("P") [vt ("y"),vt ("z"),vt ("v")])))) .|.+                                         (((.~.) (pApp ("P") [vt ("x"),vt ("v"),vt ("w")])))) .|.+                                        ((pApp ("P") [vt ("u"),vt ("z"),vt ("w")]))))) .&.+                                     ((((pApp ("P") [vt ("x"),fApp ("e") [],vt ("x")]) .&.+                                        ((pApp ("P") [fApp ("e") [],vt ("x"),vt ("x")]))) .&.+                                       (((pApp ("P") [vt ("x"),fApp ("i") [vt ("x")],fApp ("e") []]) .&.+                                         ((pApp ("P") [fApp ("i") [vt ("x")],vt ("x"),fApp ("e") []]))))))))) .&.+                                  (((pApp ("P") [vt ("x2"),vt ("x2"),fApp ("e") []]) .&.+                                    (((pApp ("P") [vt ("u2"),vt ("v2"),vt ("w2")]) .&.+                                      (((.~.) (pApp ("P") [vt ("v2"),vt ("u2"),vt ("w2")])))))))))))))))))))+                    , SkolemNormalForm+                      (((pApp ("P") [vt ("x"),vt ("y"),fApp (toSkolem 1) [vt ("x"),vt ("y")]]) .&.+                        ((((((((.~.) (pApp ("P") [vt ("x"),vt ("y"),vt ("u")])) .|.+                              (((.~.) (pApp ("P") [vt ("y"),vt ("z"),vt ("v")])))) .|.+                             (((.~.) (pApp ("P") [vt ("u"),vt ("z"),vt ("w")])))) .|.+                            ((pApp ("P") [vt ("x"),vt ("v"),vt ("w")]))) .&.+                           ((((((.~.) (pApp ("P") [vt ("x"),vt ("y"),vt ("u")])) .|.+                               (((.~.) (pApp ("P") [vt ("y"),vt ("z"),vt ("v")])))) .|.+                              (((.~.) (pApp ("P") [vt ("x"),vt ("v"),vt ("w")])))) .|.+                             ((pApp ("P") [vt ("u"),vt ("z"),vt ("w")]))))) .&.+                          ((((pApp ("P") [vt ("x"),fApp ("e") [],vt ("x")]) .&.+                             ((pApp ("P") [fApp ("e") [],vt ("x"),vt ("x")]))) .&.+                            (((pApp ("P") [vt ("x"),fApp ("i") [vt ("x")],fApp ("e") []]) .&.+                              ((pApp ("P") [fApp ("i") [vt ("x")],vt ("x"),fApp ("e") []]))))))))) .&.+                       (((pApp ("P") [fApp (toSkolem 2) [],fApp (toSkolem 2) [],fApp ("e") []]) .&.+                         (((pApp ("P") [fApp (toSkolem 3) [],fApp (toSkolem 4) [],fApp (toSkolem 5) []]) .&.+                           (((.~.) (pApp ("P") [fApp (toSkolem 4) [],fApp (toSkolem 3) [],fApp (toSkolem 5) []]))))))))+                    , SkolemNumbers (S.fromList [1,2,3,4,5])+                    -- From our algorithm++                    , ClauseNormalForm+                      (toSS +                      [[(pApp ("P") [vt ("x"),vt ("y"),fApp (toSkolem 1) [vt ("x"),vt ("y")]])],+                       [((.~.) (pApp ("P") [vt ("x"),vt ("y"),vt ("u")])),+                        ((.~.) (pApp ("P") [vt ("y"),vt ("z"),vt ("v")])),+                        ((.~.) (pApp ("P") [vt ("u"),vt ("z"),vt ("w")])),+                        (pApp ("P") [vt ("x"),vt ("v"),vt ("w")])],+                       [((.~.) (pApp ("P") [vt ("x"),vt ("y"),vt ("u")])),+                        ((.~.) (pApp ("P") [vt ("y"),vt ("z"),vt ("v")])),+                        ((.~.) (pApp ("P") [vt ("x"),vt ("v"),vt ("w")])),+                        (pApp ("P") [vt ("u"),vt ("z"),vt ("w")])],+                       [(pApp ("P") [vt ("x"),fApp ("e") [],vt ("x")])],+                       [(pApp ("P") [fApp ("e") [],vt ("x"),vt ("x")])],+                       [(pApp ("P") [vt ("x"),fApp ("i") [vt ("x")],fApp ("e") []])],+                       [(pApp ("P") [fApp ("i") [vt ("x")],vt ("x"),fApp ("e") []])],+                       [(pApp ("P") [fApp (toSkolem 2) [],fApp (toSkolem 2) [],fApp ("e") []])],+                       [(pApp ("P") [fApp (toSkolem 3) [],fApp (toSkolem 4) [],fApp (toSkolem 5) []])],+                       [((.~.) (pApp ("P") [fApp (toSkolem 4) [],fApp (toSkolem 3) [],fApp (toSkolem 5) []]))]])++                    -- From the book+{-+                    , let (a, b, c) = +                              (fApp (toSkolem 3) [vt ("x"),vt ("y"),vt ("x2"),vt ("y2"),vt ("z2"),vt ("u"),vt ("v"),vt ("w"),vt ("x2"),vt ("y2"),vt ("z2"),vt ("u2"),vt ("v2"),vt ("w2"),vt ("x3"),vt ("x3"),vt ("x3"),vt ("x3")],+                               fApp (toSkolem 4) [vt ("x"),vt ("y"),vt ("x2"),vt ("y2"),vt ("z2"),vt ("u"),vt ("v"),vt ("w"),vt ("x2"),vt ("y2"),vt ("z2"),vt ("u2"),vt ("v2"),vt ("w2"),vt ("x3"),vt ("x3"),vt ("x3"),vt ("x3")],+                               fApp (toSkolem 5) [vt ("x"),vt ("y"),vt ("x2"),vt ("y2"),vt ("z2"),vt ("u"),vt ("v"),vt ("w"),vt ("x2"),vt ("y2"),vt ("z2"),vt ("u2"),vt ("v2"),vt ("w2"),vt ("x3"),vt ("x3"),vt ("x3"),vt ("x3")]) in+                      ClauseNormalForm+                      [[(pApp "P" [vt "x",vt "y",fApp (toSkolem 1) [vt "x",vt "y"]])],+                       [((.~.) (pApp "P" [vt "x",vt "y",vt "u"])),+                        ((.~.) (pApp "P" [vt "y",vt "z",vt "v"])),+                        ((.~.) (pApp "P" [vt "u",vt "z",vt "w"])),+                        (pApp "P" [vt "x",vt "v",vt "w"])],+                       [((.~.) (pApp "P" [vt "x",vt "y",vt "u"])),+                        ((.~.) (pApp "P" [vt "y",vt "z",vt "v"])),+                        ((.~.) (pApp "P" [vt "x",vt "v",vt "w"])),+                        (pApp "P" [vt "u",vt "z",vt "w"])],+                       [(pApp "P" [vt "x",fApp "e" [],vt "x"])],+                       [(pApp "P" [fApp "e" [],vt "x",vt "x"])],+                       [(pApp "P" [vt "x",fApp "i" [vt "x"],fApp "e" []])],+                       [(pApp "P" [fApp "i" [vt "x"],vt "x",fApp "e" []])],+                       [(pApp "P" [vt "x",+                                   vt "x",+                                   fApp "e" []])],+                       [(pApp "P" [a, b, c])],+                       [((.~.) (pApp "P" [b, a, c]))]]+-}+                    ]+                }++{-+% ghci+> :load Test/Data.hs+> :m +Logic.FirstOrder+> :m +Logic.Normal+> let f = (.~.) (conj (map formula (snd chang43KB)) .=>. formula chang43Conjecture)+> putStrLn (runNormal (cnfTrace f))+-}++chang43ConjectureRenamed :: TTestFormula+chang43ConjectureRenamed =+    let e = fApp "e" []+        (x, y, z, u, v, w) = (vt "x" :: TTerm, vt "y" :: TTerm, vt "z" :: TTerm, vt "u" :: TTerm, vt "v" :: TTerm, vt "w" :: TTerm)+        (u2, v2, w2, x2, y2, z2, u3, v3, w3, x3, y3, z3, x4, x5, x6, x7, x8) =+            (vt "u2" :: TTerm, vt "v2" :: TTerm, vt "w2" :: TTerm, vt "x2" :: TTerm, vt "y2" :: TTerm, vt "z2" :: TTerm, vt "u3" :: TTerm, vt "v3" :: TTerm, vt "w3" :: TTerm, vt "x3" :: TTerm, vt "y3" :: TTerm, vt "z3" :: TTerm, vt "x4" :: TTerm, vt "x5" :: TTerm, vt "x6" :: TTerm, vt "x7" :: TTerm, vt "x8" :: TTerm) in+    TestFormula { name = "chang 43 renamed"+                , formula = (.~.) ((for_all' ["x", "y"] (exists "z" (pApp "P" [x,y,z])) .&.+                                    for_all' ["x2", "y2", "z2", "u", "v", "w"] (pApp "P" [x2, y2, u] .&. pApp "P" [y2, z2, v] .&. pApp "P" [u, z2, w] .=>. pApp "P" [x2, v, w]) .&.+                                    for_all' ["x3", "y3", "z3", "u2", "v2", "w2"] (pApp "P" [x3, y3, u2] .&. pApp "P" [y3, z3, v2] .&. pApp "P" [x3, v2, w2] .=>. pApp "P" [u2, z3, w2]) .&.+                                    for_all "x4" (pApp "P" [x4,e,x4]) .&.+                                    for_all "x5" (pApp "P" [e,x5,x5]) .&.+                                    for_all "x6" (pApp "P" [x6,fApp "i" [x6], e]) .&.+                                    for_all "x7" (pApp "P" [fApp "i" [x7], x7, e])) .=>.+                                   (for_all "x8" (pApp "P" [x8, x8, e] .=>. (for_all' ["u3", "v3", "w3"] (pApp "P" [u3, v3, w3] .=>. pApp "P" [v3, u3, w3])))))+                , expected =+                    [ FirstOrderFormula+                      ((.~.) ((((((((for_all' ["x","y"] (exists "z" (pApp "P" [vt "x",vt "y",vt "z"]))) .&.+                                    ((for_all' ["x2","y2","z2","u","v","w"] ((((pApp "P" [vt "x2",vt "y2",vt "u"]) .&.+                                                                                          ((pApp "P" [vt "y2",vt "z2",vt "v"]))) .&.+                                                                                         ((pApp "P" [vt "u",vt "z2",vt "w"]))) .=>.+                                                                                        ((pApp "P" [vt "x2",vt "v",vt "w"])))))) .&.+                                   ((for_all' ["x3","y3","z3","u2","v2","w2"] ((((pApp "P" [vt "x3",vt "y3",vt "u2"]) .&.+                                                                                            ((pApp "P" [vt "y3",vt "z3",vt "v2"]))) .&.+                                                                                           ((pApp "P" [vt "x3",vt "v2",vt "w2"]))) .=>.+                                                                                          ((pApp "P" [vt "u2",vt "z3",vt "w2"])))))) .&.+                                  ((for_all "x4" (pApp "P" [vt "x4",fApp "e" [],vt "x4"])))) .&.+                                 ((for_all "x5" (pApp "P" [fApp "e" [],vt "x5",vt "x5"])))) .&.+                                ((for_all "x6" (pApp "P" [vt "x6",fApp "i" [vt "x6"],fApp "e" []])))) .&.+                               ((for_all "x7" (pApp "P" [fApp "i" [vt "x7"],vt "x7",fApp "e" []])))) .=>.+                              ((for_all "x8" ((pApp "P" [vt "x8",vt "x8",fApp "e" []]) .=>.+                                                  ((for_all' ["u3","v3","w3"] ((pApp "P" [vt "u3",vt "v3",vt "w3"]) .=>.+                                                                                    ((pApp "P" [vt "v3",vt "u3",vt "w3"]))))))))))+                    , let a = fApp (toSkolem 3) []+                          b = fApp (toSkolem 4) []+                          c = fApp (toSkolem 5) [] in+                      ClauseNormalForm+                      (toSS+                      [[(pApp ("P") [vt ("x"),vt ("y"),fApp (toSkolem 1) [vt ("x"),vt ("y")]])],+                       [((.~.) (pApp ("P") [vt ("x"),vt ("y"),vt ("u")])),+                        ((.~.) (pApp ("P") [vt ("y"),vt ("z2"),vt ("v")])),+                        ((.~.) (pApp ("P") [vt ("u"),vt ("z2"),vt ("w")])),+                        (pApp ("P") [vt ("x"),vt ("v"),vt ("w")])],+                       [((.~.) (pApp ("P") [vt ("x"),vt ("y"),vt ("u")])),+                        ((.~.) (pApp ("P") [vt ("y"),vt ("z2"),vt ("v")])),+                        ((.~.) (pApp ("P") [vt ("x"),vt ("v"),vt ("w")])),+                        (pApp ("P") [vt ("u"),vt ("z2"),vt ("w")])],+                       [(pApp ("P") [vt ("x"),fApp ("e") [],vt ("x")])],+                       [(pApp ("P") [fApp ("e") [],vt ("x"),vt ("x")])],+                       [(pApp ("P") [vt ("x"),fApp ("i") [vt ("x")],fApp ("e") []])],+                       [(pApp ("P") [fApp ("i") [vt ("x")],vt ("x"),fApp ("e") []])],+                       [(pApp ("P") [fApp (toSkolem 2) [],fApp (toSkolem 2) [],fApp ("e") []])],+                       [(pApp ("P") [a,b,c])],+                       [((.~.) (pApp ("P") [b,a,c]))]])                      +                    ]+                }++withKB :: forall formula atom term v p f. (formula ~ TFormula, atom ~ TAtom, v ~ V, FirstOrderFormula formula atom v, AtomEq atom p term, Term term v f) =>+          (String, [TestFormula formula atom v]) -> TestFormula formula atom v -> TestFormula formula atom v+withKB (kbName, knowledge) conjecture =+    conjecture { name = name conjecture ++ " with " ++ kbName ++ " knowledge base"+               -- Here we say that the conjunction of the knowledge+               -- base formula implies the conjecture.  We prove the+               -- theorem by showing that the negation is+               -- unsatisfiable.+               , formula = (.~.) (conj (map formula knowledge) .=>. formula conjecture)}+    where+      conj [] = error "conj []"+      conj [x] = x+      conj (x:xs) = x .&. conj xs++kbKnowledge :: forall formula atom term v p f. (formula ~ TFormula, atom ~ TAtom, v ~ V,+                                                FirstOrderFormula formula atom v, AtomEq atom p term, Term term v f) =>+               (String, [TestFormula formula atom v]) -> (String, [formula])+kbKnowledge kb = (fst (kb :: (String, [TestFormula formula atom v])), map formula (snd kb))++proofs :: forall formula atom term v p f. (formula ~ TFormula, atom ~ TAtom, v ~ V,+                                           FirstOrderFormula formula atom v, AtomEq atom p term, Term term v f, Ord formula, IsString v, IsString p, IsString f) =>+          [TestProof formula term v]+proofs =+    let -- dog = pApp "Dog" :: [term] -> formula+        -- cat = pApp "Cat" :: [term] -> formula+        -- owns = pApp "Owns" :: [term] -> formula+        kills = pApp "Kills"+        -- animal = pApp "Animal" :: [term] -> formula+        -- animalLover = pApp "AnimalLover" :: [term] -> formula+        socrates = pApp "Socrates"+        -- human = pApp "Human" :: [term] -> formula+        mortal = pApp "Mortal"++        jack = fApp "Jack" []+        tuna = fApp "Tuna" []+        curiosity = fApp "Curiosity" [] in++    [ TestProof+      { proofName = "prove jack kills tuna"+      , proofKnowledge = kbKnowledge animalKB+      , conjecture = kills [jack, tuna]+      , proofExpected = +          [ ChiouKB (S.fromList+                     [WithId {wiItem = INF (S.fromList []) (S.fromList [(pApp "Dog" [fApp (toSkolem 1) []])]), wiIdent = 1},+                      WithId {wiItem = INF (S.fromList []) (S.fromList [(pApp "Owns" [fApp "Jack" [],fApp (toSkolem 1) []])]), wiIdent = 1},+                      WithId {wiItem = INF (S.fromList [(pApp "Dog" [vt "y"]),(pApp "Owns" [vt "x",vt "y"])]) (S.fromList [(pApp "AnimalLover" [vt "x"])]), wiIdent = 2},+                      WithId {wiItem = INF (S.fromList [(pApp "Animal" [vt "y"]),(pApp "AnimalLover" [vt "x"]),(pApp "Kills" [vt "x",vt "y"])]) (S.fromList []), wiIdent = 3},+                      WithId {wiItem = INF (S.fromList []) (S.fromList [(pApp "Kills" [fApp "Curiosity" [],fApp "Tuna" []]),(pApp "Kills" [fApp "Jack" [],fApp "Tuna" []])]), wiIdent = 4},+                      WithId {wiItem = INF (S.fromList []) (S.fromList [(pApp "Cat" [fApp "Tuna" []])]), wiIdent = 5},+                      WithId {wiItem = INF (S.fromList [(pApp "Cat" [vt "x"])]) (S.fromList [(pApp "Animal" [vt "x"])]), wiIdent = 6}])+          , ChiouResult (False,+                         (S.fromList+                          [(inf' [(pApp "Kills" [fApp "Jack" [],fApp "Tuna" []])] [],fromList []),+                           (inf' [] [(pApp "Kills" [fApp "Curiosity" [],fApp "Tuna" []])],fromList []),+                           (inf' [(pApp "Animal" [fApp "Tuna" []]),(pApp "AnimalLover" [fApp "Curiosity" []])] [],fromList []),+                           (inf' [(pApp "Animal" [fApp "Tuna" []]),(pApp "Dog" [vt "y"]),(pApp "Owns" [fApp "Curiosity" [],vt "y"])] [],fromList []),+                           (inf' [(pApp "AnimalLover" [fApp "Curiosity" []]),(pApp "Cat" [fApp "Tuna" []])] [],fromList []),+                           (inf' [(pApp "Animal" [fApp "Tuna" []]),(pApp "Owns" [fApp "Curiosity" [],fApp (toSkolem 1) []])] [],fromList []),+                           (inf' [(pApp "Cat" [fApp "Tuna" []]),(pApp "Dog" [vt "y"]),(pApp "Owns" [fApp "Curiosity" [],vt "y"])] [],fromList []),+                           (inf' [(pApp "AnimalLover" [fApp "Curiosity" []])] [],fromList []),+                           (inf' [(pApp "Cat" [fApp "Tuna" []]),(pApp "Owns" [fApp "Curiosity" [],fApp (toSkolem 1) []])] [],fromList []),+                           (inf' [(pApp "Dog" [vt "y"]),(pApp "Owns" [fApp "Curiosity" [],vt "y"])] [],fromList []),+                           (inf' [(pApp "Owns" [fApp "Curiosity" [],fApp (toSkolem 1) []])] [],fromList [])]))+          ]+      }+    , TestProof+      { proofName = "prove curiosity kills tuna"+      , proofKnowledge = kbKnowledge animalKB+      , conjecture = kills [curiosity, tuna]+      , proofExpected =+          [ ChiouKB (S.fromList+                     [WithId {wiItem = inf' []                                 [(pApp "Dog" [fApp (toSkolem 1) []])],                 wiIdent = 1},+                      WithId {wiItem = inf' []                                 [(pApp "Owns" [fApp "Jack" [],fApp (toSkolem 1) []])], wiIdent = 1},+                      WithId {wiItem = inf' [(pApp "Dog" [vt "y"]),+                                             (pApp "Owns" [vt "x",vt "y"])]  [(pApp "AnimalLover" [vt "x"])],                      wiIdent = 2},+                      WithId {wiItem = inf' [(pApp "Animal" [vt "y"]),+                                             (pApp "AnimalLover" [vt "x"]),+                                             (pApp "Kills" [vt "x",vt "y"])] [], wiIdent = 3},+                      WithId {wiItem = inf' []                                 [(pApp "Kills" [fApp "Curiosity" [],fApp "Tuna" []]),+                                                                                (pApp "Kills" [fApp "Jack" [],fApp "Tuna" []])],      wiIdent = 4},+                      WithId {wiItem = inf' []                                 [(pApp "Cat" [fApp "Tuna" []])],                       wiIdent = 5},+                      WithId {wiItem = inf' [(pApp "Cat" [vt "x"])]           [(pApp "Animal" [vt "x"])],                           wiIdent = 6}])+          , ChiouResult (True,+                         S.fromList +                         [(makeINF' ([]) ([]),fromList []),+                          (makeINF' ([]) ([(pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])]),fromList []),+                          (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []])]) ([]),fromList []),+                          (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("AnimalLover") [fApp ("Jack") []])]) ([]),fromList []),+                          (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Dog") [vt ("y")]),(pApp ("Owns") [fApp ("Jack") [],vt ("y")])]) ([]),fromList []),+                          (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Dog") [fApp (toSkolem 1) []])]) ([]),fromList []),+                          (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem 1) []])]) ([]),fromList []),+                          (makeINF' ([(pApp ("AnimalLover") [fApp ("Jack") []])]) ([]),fromList []),+                          (makeINF' ([(pApp ("AnimalLover") [fApp ("Jack") []]),(pApp ("Cat") [fApp ("Tuna") []])]) ([]),fromList []),+                          (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []])]) ([]),fromList []),+                          (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Dog") [vt ("y")]),(pApp ("Owns") [fApp ("Jack") [],vt ("y")])]) ([]),fromList []),+                          (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Dog") [fApp (toSkolem 1) []])]) ([]),fromList []),+                          (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem 1) []])]) ([]),fromList []),+                          (makeINF' ([(pApp ("Dog") [vt ("y")]),(pApp ("Owns") [fApp ("Jack") [],vt ("y")])]) ([]),fromList []),+                          (makeINF' ([(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []])]) ([]),fromList [])])+          ]+      }+{-+  -- Seems not to terminate+    , let (x, u, v, w, e) = (vt "x", vt "u", vt "v", vt "w", vt "e") in+      TestProof+      { proofName = "chang example 4.3"+      , proofKnowledge = (fst chang43KB, map (convertFOF id id id . formula) (snd chang43KB))+      , conjecture = for_all' ["x"] (pApp "P" [x, x, e] .=>. (for_all' ["u", "v", "w"] (pApp "P" [u, v, w] .=>. pApp "P" [v, u, w])))+      , proofExpected =+          [ChiouResult (True, [])]+      }+-}+    , let x = vt "x" in+      TestProof+      { proofName = "socrates is mortal"+      , proofKnowledge = kbKnowledge (socratesKB)+      , conjecture = for_all "x" (socrates [x] .=>. mortal [x])+      , proofExpected = +         [ ChiouKB (S.fromList+                    [WithId {wiItem = inf' [(pApp "Human" [vt "x"])] [(pApp "Mortal" [vt "x"])], wiIdent = 1},+                     WithId {wiItem = inf' [(pApp "Socrates" [vt "x"])] [(pApp "Human" [vt "x"])], wiIdent = 2}])+         , ChiouResult (True,+                        S.fromList +                        [(makeINF' ([]) ([]),fromList []),+                         (makeINF' ([]) ([(pApp ("Human") [fApp (toSkolem 3) []])]),fromList []),+                         (makeINF' ([]) ([(pApp ("Mortal") [fApp (toSkolem 3) []])]),fromList []),+                         (makeINF' ([]) ([(pApp ("Socrates") [fApp (toSkolem 3) []])]),fromList []),+                         (makeINF' ([(pApp ("Mortal") [fApp (toSkolem 3) []])]) ([]),fromList [])])]+      }+    , let x = vt "x" in+      TestProof+      { proofName = "socrates is not mortal"+      , proofKnowledge = kbKnowledge (socratesKB)+      , conjecture = (.~.) (for_all "x" (socrates [x] .=>. mortal [x]))+      , proofExpected = +         [ ChiouKB (S.fromList+                    [WithId {wiItem = inf' [(pApp "Human" [vt "x"])] [(pApp "Mortal" [vt "x"])], wiIdent = 1},+                     WithId {wiItem = inf' [(pApp "Socrates" [vt "x"])] [(pApp "Human" [vt "x"])], wiIdent = 2}])+         , ChiouResult (False+                       ,(S.fromList [(inf' [(pApp "Socrates" [vt "x"])] [(pApp "Mortal" [vt "x"])],fromList [("x",vt "x")])]))]+      }+    , let x = vt "x" in+      TestProof+      { proofName = "socrates exists and is not mortal"+      , proofKnowledge = kbKnowledge (socratesKB)+      , conjecture = (.~.) (exists "x" (socrates [x]) .&. for_all "x" (socrates [x] .=>. mortal [x]))+      , proofExpected = +         [ ChiouKB (S.fromList+                    [WithId {wiItem = inf' [(pApp "Human" [vt "x"])] [(pApp "Mortal" [vt "x"])], wiIdent = 1},+                     WithId {wiItem = inf' [(pApp "Socrates" [vt "x"])] [(pApp "Human" [vt "x"])], wiIdent = 2}])+         , ChiouResult (False,+                        S.fromList [(makeINF' ([]) ([(pApp ("Human") [fApp (toSkolem 3) []])]),fromList []),+                                    (makeINF' ([]) ([(pApp ("Mortal") [fApp (toSkolem 3) []])]),fromList []),+                                    (makeINF' ([]) ([(pApp ("Socrates") [fApp (toSkolem 3) []])]),fromList []),+                                    (makeINF' ([(pApp ("Socrates") [vt ("x")])]) ([(pApp ("Mortal") [vt ("x")])]),fromList [("x",vt ("x"))])])+         ]+      }+    ]++inf' = makeINF'++toLL = map S.toList . S.toList+toSS = S.fromList . map S.fromList
+ Data/Logic/Tests/Harrison/Equal.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeSynonymInstances #-}+{-# OPTIONS_GHC -Wall #-}+module Data.Logic.Tests.Harrison.Equal where++-- ========================================================================= +-- First order logic with equality.                                          +--                                                                           +-- Copyright (co) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)  +-- ========================================================================= ++import Control.Applicative.Error (Failing(..))+import Data.Logic.Classes.Combine (Combinable(..), (∧), (⇒))+import Data.Logic.Classes.Equals ((.=.), pApp)+import Data.Logic.Classes.FirstOrder ((∃), (∀))+import Data.Logic.Classes.Skolem (Skolem(..))+import Data.Logic.Classes.Term (Term(..))+import Data.Logic.Harrison.Equal (equalitize, function_congruence)+import Data.Logic.Harrison.Meson (meson)+import Data.Logic.Harrison.Skolem (runSkolem)+import Data.Logic.Types.Harrison.FOL (TermType(..))+import Data.Logic.Types.Harrison.Formulas.FirstOrder (Formula(..))+import Data.Logic.Types.Harrison.Equal (FOLEQ(..), PredName)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.String (IsString(fromString))+-- import Test.HUnit (Test(TestCase, TestList, TestLabel), assertEqual)+import Data.Logic.Tests.Harrison.HUnit++-- type TF = TestFormula (Formula FOL) FOL TermType String String Function+-- type TFE = TestFormulaEq (Formula FOLEQ) FOLEQ TermType String String Function++tests :: Test (Formula FOLEQ)+tests = TestLabel "Data.Logic.Tests.Harrison.Equal" $ TestList [test01, test02, test03, test04]++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test01 :: Test (Formula FOLEQ)+test01 = TestCase $ assertEqual "function_congruence" expected input+    where input = map function_congruence [(fromString "f", 3 :: Int), (fromString "+",2)]+          expected :: [Set.Set (Formula FOLEQ)]+          expected = [Set.fromList+                      [(∀) x1+                       ((∀) x2+                        ((∀) x3+                         ((∀) y1+                          ((∀) y2+                           ((∀) y3 ((((vt x1) .=. (vt y1)) ∧ (((vt x2) .=. (vt y2)) ∧ ((vt x3) .=. (vt y3)))) ⇒+                                          ((fApp (fromString "f") [vt x1,vt x2,vt x3]) .=. (fApp (fromString "f") [vt y1,vt y2,vt y3]))))))))],+                      Set.fromList+                      [(∀) x1+                       ((∀) x2+                        ((∀) y1+                         ((∀) y2 ((((vt x1) .=. (vt y1)) ∧ ((vt x2) .=. (vt y2))) ⇒+                                        ((fApp (fromString "+") [vt x1,vt x2]) .=. (fApp (fromString "+") [vt y1,vt y2]))))))]]+          x1 = fromString "x1"+          x2 = fromString "x2"+          x3 = fromString "x3"+          y1 = fromString "y1"+          y2 = fromString "y2"+          y3 = fromString "y3"++-- ------------------------------------------------------------------------- +-- A simple example (see EWD1266a and the application to Morley's theorem).  +-- ------------------------------------------------------------------------- ++test :: (Show a, Eq a) => String -> a -> a -> Test (Formula FOLEQ)+test label expected input = TestLabel label $ TestCase $ assertEqual label expected input++test02 :: Test (Formula FOLEQ)+test02 = test "equalitize 1 (p. 241)" expected input+    where input = runSkolem (meson (Just 5) ewd)+          ewd :: Formula FOLEQ+          ewd = equalitize fm+          fm :: Formula FOLEQ+          fm = ((∀) x (fx ⇒ gx)) ∧ ((∃) x fx) ∧ ((∀) x ((∀) y (gx ∧ gy ⇒ vt x .=. vt y))) ⇒+               (∀) y gy ⇒ fy+          fx = pApp' "f" [vt x]+          gx = pApp' "g" [vt x]+          fy = pApp' "f" [vt y]+          gy = pApp' "g" [vt y]+          x = fromString "x"+          y = fromString "y"+          -- y1 = fromString "y1"+          -- z = fromString "z"+          expected =+              Set.singleton (Success ((Map.fromList [(fromString "_0",vt' "_2"),+                                                     (fromString "_1",fApp (toSkolem 1) []),+                                                     (fromString "_2",vt' "_4"),+                                                     (fromString "_3",fApp (toSkolem 1) []),+                                                     (fromString "_4",fApp (toSkolem 2) []),+                                                     (fromString "_5",fApp (toSkolem 1) [])], 0, 6), 5))+{-+          fApp' :: String -> [term] -> term+          fApp' s ts = fApp (fromString s) ts+          for_all' s = for_all (fromString s)+          exists' s = exists (fromString s)+-}+          pApp' :: String -> [TermType] -> Formula FOLEQ+          pApp' s ts = pApp (fromString s :: PredName) ts+          vt' :: String -> TermType+          vt' s = vt (fromString s)++-- ------------------------------------------------------------------------- +-- Wishnu Prasetya's example (even nicer with an "exists unique" primitive). +-- ------------------------------------------------------------------------- ++test03 :: Test (Formula FOLEQ)+test03 = TestLabel "equalitize 2" $ TestCase $ assertEqual "equalitize 2 (p. 241)" expected input+    where input = runSkolem (meson (Just 1) wishnu)+          wishnu = equalitize fm+          fm :: Formula FOLEQ+          fm = ((∃) (fromString "x") ((x .=. f[g[x]]) ∧ (∀) (fromString "x'") ((x' .=. f[g[x']]) ⇒ (x .=. x')))) .<=>.+               ((∃) (fromString "y") ((y .=. g[f[y]]) ∧ (∀) (fromString "y'") ((y' .=. g[f[y']]) ⇒ (y .=. y'))))+          x = vt (fromString "x")+          y = vt (fromString "y")+          x' = vt (fromString "x'")+          y' = vt (fromString "y")+          f terms = fApp (fromString "f") terms+          g terms = fApp (fromString "g") terms+          expected = Set.singleton (Failure ["Exceeded maximum depth limit"])++-- ------------------------------------------------------------------------- +-- More challenging equational problems. (Size 18, 61814 seconds.)           +-- ------------------------------------------------------------------------- ++test04 :: Test (Formula FOLEQ)+test04 = test "equalitize 3 (p. 248)" expected input+    where+      input = runSkolem (meson (Just 20) . equalitize $ fm)+      fm :: Formula FOLEQ+      fm = ((∀) "x" . (∀) "y" . (∀) "z") ((*) [x', (*) [y', z']] .=. (*) [((*) [x', y']), z']) ∧+           (∀) "x" ((*) [one, x'] .=. x') ∧+           (∀) "x" ((*) [i [x'], x'] .=. one) ⇒+           (∀) "x" ((*) [x', i [x']] .=. one)+      x' = vt "x" :: TermType+      y' = vt "y" :: TermType+      z' = vt "z" :: TermType+      (*) = fApp (fromString "*")+      i = fApp (fromString "i")+      one = fApp (fromString "1") []+      expected :: Set.Set (Failing ((Map.Map String TermType, Int, Int), Int))+      expected =+          Set.fromList+                 [Success ((Map.fromList+                                   [( "_0",  (*) [one, vt' "_3"]),+                                    ( "_1",  (*) [fApp (toSkolem 1) [],i [fApp (toSkolem 1) []]]),+                                    ( "_2",  one),+                                    ( "_3",  (*) [fApp (toSkolem 1) [],i [fApp (toSkolem 1) []]]),+                                    ( "_4",  vt' "_8"),+                                    ( "_5",  (*) [one, vt' "_3"]),+                                    ( "_6",  one),+                                    ( "_7",  vt' "_11"),+                                    ( "_8",  vt' "_12"),+                                    ( "_9",  (*) [one, vt' "_3"]),+                                    ("_10", (*) [vt' "_13",(*) [vt' "_14", vt' "_15"]]),+                                    ("_11", (*) [(*) [vt' "_13", vt' "_14"], vt' "_15"]),+                                    ("_12", (*) [vt' "_19", vt' "_18"]),+                                    ("_13", vt' "_16"),+                                    ("_14", vt' "_21"),+                                    ("_15", (*) [vt' "_22", vt' "_23"]),+                                    ("_16", vt' "_20"),+                                    ("_17", (*) [vt' "_14", vt' "_15"]),+                                    ("_18", (*) [(*) [vt' "_21", vt' "_22"], vt' "_23"]),+                                    ("_19", vt' "_20"),+                                    ("_20", i [vt' "_28"]),+                                    ("_21", vt' "_28"),+                                    ("_22", fApp (toSkolem 1) []),+                                    ("_23", i [fApp (toSkolem 1) []]),+                                    ("_24", (*) [vt' "_13", vt' "_14"]),+                                    ("_25", (*) [vt' "_22", vt' "_23"]),+                                    ("_26", (*) [fApp (toSkolem 1) [],i [fApp (toSkolem 1) []]]),+                                    ("_27", one),+                                    ("_28", vt' "_30"),+                                    ("_29", (*) [vt' "_22", vt' "_23"]),+                                    ("_30", (*) [(*) [vt' "_21", vt' "_22"], vt' "_23"])],+                            0,31),13)]+      vt' = vt . fromString
+ Data/Logic/Tests/Harrison/FOL.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes,+             ScopedTypeVariables, TypeFamilies, TypeSynonymInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Data.Logic.Tests.Harrison.FOL+    ( tests1+    , tests2+    , example1+    , example2+    , example3+    , example4+    ) where++import Control.Applicative ((<$>), (<*>))+import Control.Applicative.Error (Failing(..))+import Control.Monad (filterM)+import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..))+import Data.Logic.Classes.Constants (Constants(false))+import Data.Logic.Classes.Equals (AtomEq(..), (.=.))+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..))+import qualified Data.Logic.Classes.FirstOrder as C+import Data.Logic.Classes.Negate ((.~.))+import Data.Logic.Classes.Term (Term(vt, fApp, foldTerm))+import Data.Logic.Classes.Variable (Variable(..))+import Data.Logic.Harrison.Lib ((|->))+import Data.Logic.Tests.Harrison.HUnit+import Data.Logic.Types.Harrison.Equal (FOLEQ, PredName(..))+import Data.Logic.Types.Harrison.FOL (TermType(..), FOL(..), Function(..))+import Data.Logic.Types.Harrison.Formulas.FirstOrder (Formula(..))+import qualified Data.Map as Map+import qualified Data.Set as Set+import Prelude hiding (pred)++tests1 :: TestFormula formula atom term v p f => Test formula+tests1 = TestLabel "Data.Logic.Tests.Harrison.FOL" $+        TestList [test01, test02, test03, test04, test05,+                  test06, test07, test08, test09]+tests2 :: TestFormulaEq formula atom term v p f => Test formula+tests2 = TestLabel "Data.Logic.Tests.Harrison.FOL" $+         TestList [{-test10, test11, test12-}]++-- ------------------------------------------------------------------------- +-- Semantics, implemented of course for finite domains only.                 +-- ------------------------------------------------------------------------- ++termval :: (Term term v f, Show v) =>+           ([a], f -> [a] -> a, p -> [a] -> Bool)+        -> Map.Map v a+        -> term+        -> Failing a+termval m@(_domain, func, _pred) v tm =+    foldTerm (\ x -> maybe (Failure ["Undefined variable: " ++ show x]) Success (Map.lookup x v))+             (\ f args -> mapM (termval m v) args >>= return . func f)+             tm++holds :: forall formula atom term v p f a.+         (FirstOrderFormula formula atom v, AtomEq atom p term, Term term v f, Show v, Eq a) =>+         ([a], f -> [a] -> a, p -> [a] -> Bool)+      -> Map.Map v a+      -> formula+      -> Failing Bool+holds m@(domain, _func, pred) v fm =+    foldFirstOrder qu co tf at fm+    where+      qu op x p = mapM (\ a -> holds m ((|->) x a v) p) domain >>= return . (asPred op) (== True)+      asPred C.Exists = any+      asPred C.Forall = all+      co ((:~:) p) = holds m v p >>= return . not+      co (BinOp p (:|:) q) = (||) <$> (holds m v p) <*> (holds m v q)+      co (BinOp p (:&:) q) = (&&) <$> (holds m v p) <*> (holds m v q)+      co (BinOp p (:=>:) q) = (||) <$> (not <$> (holds m v p)) <*> (holds m v q)+      co (BinOp p (:<=>:) q) = (==) <$> (holds m v p) <*> (holds m v q)+      tf x = Success x+      at :: atom -> Failing Bool+      at = foldAtomEq (\ r args -> mapM (termval m v) args >>= return . pred r) return (\ t1 t2 -> return $ termval m v t1 == termval m v t2)++-- | This becomes a method in FirstOrderFormulaEq, so it is not exported here.+-- (.=.) :: TermType -> TermType -> Formula FOL+-- a .=. b = Atom (R "=" [a, b])++-- -------------------------------------------------------------------------+-- Example.                                                                 +-- -------------------------------------------------------------------------++example1 :: TermType+example1 = fApp "sqrt" [fApp "-" [fApp "1" [], fApp "cos" [fApp "power" [fApp "+" [vt "x", vt "y"], fApp "2" []]]]]+-- example1 = Fn "sqrt" [Fn "-" [Fn "1" [], Fn "cos" [Fn "power" [Fn "+" [vt "x", vt "y"], Fn "2" []]]]]++-- -------------------------------------------------------------------------+-- Trivial example of "x + y < z".                                           +-- ------------------------------------------------------------------------- ++example2 :: Formula FOL+example2 = C.pApp "<" [fApp "+" [vt "x", vt "y"], vt "z"]+-- example2 = Atom (R "<" [Fn "+" [Var "x", Var "y"], Var "z"])++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++example3 :: Formula FOL+example3 = (for_all "x" (C.pApp "<" [vt "x", fApp "2" []] .=>.+                         C.pApp "<=" [fApp "*" [fApp "2" [], vt "x"], fApp "3" []])) .|. false+example4 :: TermType+example4 = fApp "*" [fApp "2" [], vt "x"]++-- ------------------------------------------------------------------------- +-- Examples of particular interpretations.                                   +-- ------------------------------------------------------------------------- ++boolInterp :: ([Bool], Function -> [Bool] -> Bool, PredName -> [Bool] -> Bool)+boolInterp =+    ([False, True],func,pred)+    where+      func f args =+          case (f,args) of+            ("0",[]) -> False+            ("1",[]) -> True+            ("+",[x, y]) -> not (x == y)+            ("*",[x, y]) -> x && y+            _ -> error "uninterpreted function"+      pred p args =+          case (p,args) of+            ((:=:), [x, y]) -> x == y+            _ -> error "uninterpreted predicate"++modInterp :: Integer+          -> ([Integer],+              Function -> [Integer] -> Integer,+              PredName -> [Integer] -> Bool)+modInterp n =+    ([0..(n-1)],func,pred)+    where+      func :: Function -> [Integer] -> Integer+      func f args =+          case (f,args) of+            ("0",[]) -> 0+            ("1",[]) -> 1 `mod` n+            ("+",[x, y]) -> (x + y) `mod` n+            ("*",[x, y]) -> (x * y) `mod` n+            _ -> error "uninterpreted function"+      pred :: PredName -> [Integer] -> Bool+      pred p args =+          case (p,args) of+            ((:=:),[x, y]) -> x == y+            _ -> error "uninterpreted predicate"++-- test01 :: forall formula atom term v p f. TestFormula formula atom term v p f => Test formula+test01 = TestCase $ assertEqual "holds bool test (p. 126)" expected input+    where input = holds boolInterp Map.empty (for_all "x" (vt "x" .=. fApp "0" [] .|. vt "x" .=. fApp "1" []) :: Formula FOLEQ)+          expected = Success True+-- test02 :: forall formula atom term v p f. TestFormula formula atom term v p f => Test formula+test02 = TestCase $ assertEqual "holds mod test 1 (p. 126)" expected input+    where input =  holds (modInterp 2) Map.empty (for_all "x" (vt "x" .=. (fApp "0" [] :: TermType) .|. vt "x" .=. (fApp "1" [] :: TermType)) :: Formula FOLEQ)+          expected = Success True+-- test03 :: forall formula atom term v p f. TestFormula formula atom term v p f => Test formula+test03 = TestCase $ assertEqual "holds mod test 2 (p. 126)" expected input+    where input =  holds (modInterp 3) Map.empty (for_all "x" (vt "x" .=. fApp "0" [] .|. vt "x" .=. fApp "1" []) :: Formula FOLEQ)+          expected = Success False++-- test04 :: forall formula atom term v p f. TestFormula formula atom term v p f => Test formula+test04 = TestCase $ assertEqual "holds mod test 3 (p. 126)" expected input+    where input = filterM (\ n -> holds (modInterp n) Map.empty fm) [1..45]+                  where fm = for_all "x" ((.~.) (vt "x" .=. fApp "0" []) .=>. exists "y" (fApp "*" [vt "x", vt "y"] .=. fApp "1" [])) :: Formula FOLEQ+          expected = Success [1,2,3,5,7,11,13,17,19,23,29,31,37,41,43]++-- test05 :: forall formula atom term v p f. TestFormula formula atom term v p f => Test formula+test05 = TestCase $ assertEqual "holds mod test 4 (p. 129)" expected input+    where input = holds (modInterp 3) Map.empty ((for_all "x" (vt "x" .=. fApp "0" [])) .=>. fApp "1" [] .=. fApp "0" [] :: Formula FOLEQ)+          expected = Success True+-- test06 :: forall formula atom term v p f. TestFormula formula atom term v p f => Test formula+test06 = TestCase $ assertEqual "holds mod test 5 (p. 129)" expected input+    where input = holds (modInterp 3) Map.empty (for_all "x" (vt "x" .=. fApp "0" [] .=>. fApp "1" [] .=. fApp "0" []) :: Formula FOLEQ)+          expected = Success False++-- ------------------------------------------------------------------------- +-- Variant function and examples.                                            +-- ------------------------------------------------------------------------- ++-- test07 :: forall formula atom term v p f. TestFormula formula atom term v p f => Test formula+test07 = TestCase $ assertEqual "variant 1 (p. 133)" expected input+    where input = variant "x" (Set.fromList ["y", "z"]) :: String+          expected = "x"+-- test08 :: forall formula atom term v p f. TestFormula formula atom term v p f => Test formula+test08 = TestCase $ assertEqual "variant 2 (p. 133)" expected input+    where input = variant "x" (Set.fromList ["x", "y"]) :: String+          expected = "x'"+-- test09 :: forall formula atom term v p f. TestFormula formula atom term v p f => Test formula+test09 = TestCase $ assertEqual "variant 3 (p. 133)" expected input+    where input = variant "x" (Set.fromList ["x", "x'"]) :: String+          expected = "x''"++-- ------------------------------------------------------------------------- +-- Examples.                                                                 +-- ------------------------------------------------------------------------- +{-+-- test10 :: forall formula atom term v p f. TestFormulaEq formula atom term v p f => Test formula+test10 =+    let (x, x', y) = (fromString "x", fromString "x'", fromString "y") in+    TestCase $ assertEqual "subst 1 (p. 134)" expected input+    where input = subst (y |=> vt x) (C.for_all x (vt x .=. vt y))+          expected = C.for_all x' (vt x' .=. vt x)++test11 :: forall formula atom term v p f. TestFormulaEq formula atom term v p f => Test formula+test11 = TestCase $ assertEqual "subst 2 (p. 134)" expected input+    where input = subst ("y" |=> Var "x") (C.for_all "x" (C.for_all "x'" ((vt "x" .=. vt "y") .=>. (vt "x" .=. vt "x'"))))+          expected = H.Forall "x'" (H.Forall "x''" (Imp (Atom (R "=" [Var "x'",Var "x"])) (Atom (R "=" [Var "x'",Var "x''"]))))++test12 :: forall formula atom term v p f. TestFormulaEq formula atom term v p f => Test formula+test12 = TestCase $ assertEqual "show first order formula 1" expected input+    where input = map show fms+          expected = ["((pApp \"p\" []) .&. (pApp \"q\" [])) .|. (pApp \"r\" [])",+                      "(pApp \"p\" []) .&. (pApp \"q\" []) .|. (pApp \"r\" [])",+                      "((pApp \"p\" []) .&. (pApp \"q\" [])) .|. (pApp \"r\" [])",+                      "(pApp \"p\" []) .&. ((.~.)(pApp \"q\" []))",+                      "for_all (fromString (\"x\")) ((pApp \"p\" []) .&. (pApp \"q\" []))"]+          fms :: [formula]+          fms = [(p .&. q .|. r),+                 (p .&. (q .|. r)),+                 ((p .&. q) .|. r),+                 (p .&. ((.~.) q)),+                 (for_all "x" (p .&. q))]+          p = pApp "p" []+          q = pApp "q" []+          r = pApp "r" []+-}
+ Data/Logic/Tests/Harrison/HUnit.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE MultiParamTypeClasses, RankNTypes #-}+-- | HUnit types with a type parameter.+module Data.Logic.Tests.Harrison.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 ()++-- | Provide a phantom type for a test+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+-}++instance IsString Function where+    fromString = FName
+ Data/Logic/Tests/Harrison/Main.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RankNTypes, TypeSynonymInstances #-}+module Data.Logic.Tests.Harrison.Main (tests) where++import Data.Logic.Classes.Apply (Apply)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula)+import Data.Logic.Classes.Term (Term)+import qualified Data.Logic.Harrison.Lib as Lib+import qualified Data.Logic.Tests.Harrison.Equal as Equal+import qualified Data.Logic.Tests.Harrison.FOL as FOL+import qualified Data.Logic.Tests.Harrison.Meson as Meson+import qualified Data.Logic.Tests.Harrison.Prop as Prop+import qualified Data.Logic.Tests.Harrison.Resolution as Resolution+import qualified Data.Logic.Tests.Harrison.Skolem as Skolem+import qualified Data.Logic.Tests.Harrison.Unif as Unif+import Data.Logic.Types.Harrison.Equal (FOLEQ, PredName)+import Data.Logic.Types.Harrison.FOL (FOL, TermType, Function)+import Data.Logic.Types.Harrison.Formulas.FirstOrder (Formula(..))+import Data.Logic.Tests.Harrison.HUnit+import qualified Test.HUnit as T+import Data.String (IsString)++instance TestFormula (Formula FOL) FOL TermType String String Function+instance TestFormulaEq (Formula FOLEQ) FOLEQ TermType String PredName Function++main = T.runTestTT tests++tests :: T.Test+tests =+    T.TestList+         [ Lib.tests+         , Prop.tests+         , convert (FOL.tests1 :: Test (Formula FOL))+         , convert (FOL.tests2 :: Test (Formula FOLEQ))+         , Unif.tests+         , Skolem.tests+         , convert (Resolution.tests :: Test (Formula FOLEQ))+         , convert (Equal.tests :: Test (Formula FOLEQ))+         , convert (Meson.test01 :: Test (Formula FOLEQ))+         ]
+ Data/Logic/Tests/Harrison/Meson.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleContexts, RankNTypes, ScopedTypeVariables, TypeFamilies #-}+{-# OPTIONS_GHC -Wall #-}+module Data.Logic.Tests.Harrison.Meson where++import Control.Applicative.Error (Failing(..))+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Logic.Classes.Skolem (Skolem(..))+import Data.Logic.Classes.Term (Term(vt, fApp))+import Data.Logic.Harrison.Meson(meson)+import Data.Logic.Harrison.Skolem (runSkolem)+import Data.Logic.Tests.Harrison.Resolution (dpExampleFm)+import Data.Logic.Tests.Harrison.HUnit+import Data.Logic.Types.Harrison.Equal (FOLEQ)+import Data.Logic.Types.Harrison.Formulas.FirstOrder (Formula)+import Data.String (IsString(fromString))+import Prelude hiding (negate)+-- import Test.HUnit (Test(TestCase, TestLabel), assertEqual)++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test01 :: Test (Formula FOLEQ)+test01 = TestLabel "Data.Logic.Tests.Harrison.Meson" $ TestCase $ assertEqual "meson dp example (p. 220)" expected input+    where input = runSkolem (meson (Just 10) (dpExampleFm :: Formula FOLEQ))+          expected = Set.singleton (+                                    -- Success ((Map.empty, 0, 0), 8)+                                    Success ((Map.fromList [(fromString "_0",vt' "_6"),+                                                            (fromString "_1",vt' "_2"),+                                                            (fromString "_10",fApp (toSkolem 1) [vt' "_6",vt' "_7"]),+                                                            (fromString "_11",fApp (toSkolem 1) [vt' "_6",vt' "_7"]),+                                                            (fromString "_12",fApp (toSkolem 1) [vt' "_0",vt' "_1"]),+                                                            (fromString "_13",fApp (toSkolem 1) [vt' "_0",vt' "_1"]),+                                                            (fromString "_14",fApp (toSkolem 1) [vt' "_0",vt' "_1"]),+                                                            (fromString "_15",fApp (toSkolem 1) [vt' "_12",vt' "_13"]),+                                                            (fromString "_16",fApp (toSkolem 1) [vt' "_12",vt' "_13"]),+                                                            (fromString "_17",fApp (toSkolem 1) [vt' "_12",vt' "_13"]),+                                                            (fromString "_3",fApp (toSkolem 1) [vt' "_0",vt' "_1"]),+                                                            (fromString "_4",fApp (toSkolem 1) [vt' "_0",vt' "_1"]),+                                                            (fromString "_5",fApp (toSkolem 1) [vt' "_0",vt' "_1"]),+                                                            (fromString "_7",fApp (toSkolem 1) [vt' "_0",vt' "_1"]),+                                                            (fromString "_8",fApp (toSkolem 1) [vt' "_0",vt' "_1"]),+                                                            (fromString "_9",fApp (toSkolem 1) [vt' "_6",vt' "_7"])],0,18),8)+                                   )+          vt' = vt . fromString
+ Data/Logic/Tests/Harrison/Prop.hs view
@@ -0,0 +1,396 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies #-}+{-# OPTIONS_GHC -Wall -Wwarn #-}+module Data.Logic.Tests.Harrison.Prop+    ( tests+    ) where++import Data.Logic.Classes.Combine (Combinable(..), (∨), (∧))+import Data.Logic.Classes.Constants (true, false)+import Data.Logic.Classes.Negate ((.~.), (¬))+import Data.Logic.Classes.Propositional+import Data.Logic.Harrison.Lib ((|=>))+import Data.Logic.Harrison.Prop (eval, atoms, truthTable, tautology, pSubst, psimplify,+                                 nnf, dnf, rawdnf, dual, purednf, trivial, cnf)+import Data.Logic.Types.Harrison.Formulas.Propositional (Formula(..))+import Data.Logic.Types.Harrison.Prop (Prop(..))+import qualified Data.Set as Set+import Prelude hiding (negate)+import Test.HUnit (Test(TestCase, TestList, TestLabel), assertEqual)++-- main = runTestTT tests++tests :: Test+tests = TestLabel "Data.Logic.Tests.Harrison.Prop" $+        TestList [test01, test02, test03, test04, {-test05,-}+                  test06, test07, test08, test09, test10,+                  test11, test12, test13, test14, test15,+                  test16, test17, test18, test19, test20,+                  test21, test22, test23, test24, test25,+                  test26, test27, test28, test29, test30,+                  test31, test32, test33, test34, test35,+                  test36]++-- Variables for use in test cases++-- (p, q, r, s, t, u, v) = (Atom (P "p"), Atom (P "q"), Atom (P "r"), Atom (P "s"), Atom (P "t"), Atom (P "u"), Atom (P "v"))++test36 :: Test+test36 = TestCase $ assertEqual "show propositional formula 1" expected input+    where input = map show fms+          expected = ["((P \"p\") .&. (P \"q\")) .|. (P \"r\")",+                      "(P \"p\") .&. ((P \"q\") .|. (P \"r\"))",+                      "((P \"p\") .&. (P \"q\")) .|. (P \"r\")"]+          fms :: [Formula Prop]+          fms = [p .&. q .|. r, p .&. (q .|. r), (p .&. q) .|. r]+          (p, q, r) = (Atom (P "p"), Atom (P "q"), Atom (P "r"))++-- ------------------------------------------------------------------------- +-- Testing the parser and printer.                                           +-- ------------------------------------------------------------------------- ++test01 :: Test+test01 = TestCase $ assertEqual "Build Formula 1" expected input+    where input = (p .=>. q .<=>. r .&. s .|. (t .<=>. ((.~.) ((.~.) u)) .&. v))+          expected = (Imp (Atom (P {pname = "p"}))+                          (Iff (Atom (P {pname = "q"}))+                               (Or (And (Atom (P {pname = "r"})) (Atom (P {pname = "s"})))+                                   (Iff (Atom (P {pname = "t"}))+                                        (And ({-Not-} ({-Not-} (Atom (P {pname = "u"})))) (Atom (P {pname = "v"})))))))+          (p, q, r, s, t, u, v) = (Atom (P "p"), Atom (P "q"), Atom (P "r"), Atom (P "s"), Atom (P "t"), Atom (P "u"), Atom (P "v"))++test02 :: Test+test02 = TestCase $ assertEqual "Build Formula 2" expected input+    where input = (Atom "fm" .&. Atom "fm")+          expected = (And (Atom "fm") (Atom "fm"))++test03 :: Test+test03 = TestCase $ assertEqual "Build Formula 3"+                                (Atom "fm" .|. Atom "fm" .&. Atom "fm")+                                (Or (Atom "fm") (And (Atom "fm") (Atom "fm")))++-- ------------------------------------------------------------------------- +-- Example of use.                                                           +-- ------------------------------------------------------------------------- ++test04 :: Test+test04 = TestCase $ assertEqual "fixity tests" expected input+    where (input, expected) = unzip (map (\ (fm, flag) -> (eval fm (const False), flag)) pairs)+          pairs :: [(Formula String, Bool)]+          pairs =+              [ ( true .&. false .=>. false .&. true,  True)+              , ( true .&. true  .=>. true  .&. false, False)+              , (   false ∧  true  ∨ true,             True)  -- "∧ binds more tightly than ∨"+              , (  (false ∧  true) ∨ true,             True)+              , (   false ∧ (true  ∨ true),            False)+              , (  (¬) true ∨ true,                    True)  -- "¬ binds more tightly than ∨"+              , (  (¬) (true ∨ true),                  False)+              ]++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test06 :: Test+test06 = TestCase $ assertEqual "atoms test" (atoms $ p .&. q .|. s .=>. ((.~.) p) .|. (r .<=>. s)) (Set.fromList [P "p",P "q",P "r",P "s"])+    where (p, q, r, s) = (Atom (P "p"), Atom (P "q"), Atom (P "r"), Atom (P "s"))++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test07 :: Test+test07 = TestCase $ assertEqual "truth table 1 (p. 36)" expected input+    where input = (truthTable $ p .&. q .=>. q .&. r)+          expected =+              [([(P "p",False),(P "q",False),(P "r",False)],True),+               ([(P "p",False),(P "q",False),(P "r",True)],True),+               ([(P "p",False),(P "q",True),(P "r",False)],True),+               ([(P "p",False),(P "q",True),(P "r",True)],True),+               ([(P "p",True),(P "q",False),(P "r",False)],True),+               ([(P "p",True),(P "q",False),(P "r",True)],True),+               ([(P "p",True),(P "q",True),(P "r",False)],False),+               ([(P "p",True),(P "q",True),(P "r",True)],True)]+          (p, q, r) = (Atom (P "p"), Atom (P "q"), Atom (P "r"))++-- ------------------------------------------------------------------------- +-- Additional examples illustrating formula classes.                         +-- ------------------------------------------------------------------------- ++test08 :: Test+test08 = TestCase $+    assertEqual "truth table 2 (p. 39)"+                (truthTable $  ((p .=>. q) .=>. p) .=>. p)+                [([(P "p",False),(P "q",False)],True),+                 ([(P "p",False),(P "q",True)],True),+                 ([(P "p",True),(P "q",False)],True),+                 ([(P "p",True),(P "q",True)],True)]+        where (p, q) = (Atom (P "p"), Atom (P "q"))++test09 :: Test+test09 = TestCase $+    assertEqual "truth table 3 (p. 40)" expected input+        where input = (truthTable $ p .&. ((.~.) p))+              expected = [([(P "p",False)],False),+                          ([(P "p",True)],False)]+              p = Atom (P "p")++-- ------------------------------------------------------------------------- +-- Examples.                                                                 +-- ------------------------------------------------------------------------- ++test10 :: Test+test10 = TestCase $ assertEqual "tautology 1 (p. 41)" True (tautology $ p .|. ((.~.) p)) where p = Atom (P "p")+test11 :: Test+test11 = TestCase $ assertEqual "tautology 2 (p. 41)" False (tautology $ p .|. q .=>. p) where (p, q) = (Atom (P "p"), Atom (P "q"))+test12 :: Test+test12 = TestCase $ assertEqual "tautology 3 (p. 41)" False (tautology $ p .|. q .=>. q .|. (p .<=>. q)) where (p, q) = (Atom (P "p"), Atom (P "q"))+test13 :: Test+test13 = TestCase $ assertEqual "tautology 4 (p. 41)" True (tautology $ (p .|. q) .&. ((.~.)(p .&. q)) .=>. ((.~.)p .<=>. q)) where (p, q) = (Atom (P "p"), Atom (P "q"))++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test14 :: Test+test14 =+    TestCase $ assertEqual "pSubst (p. 41)" expected input+        where expected = (p .&. q) .&. q .&. (p .&. q) .&. q+              input = pSubst ((P "p") |=> (p .&. q)) (p .&. q .&. p .&. q)+              (p, q) = (Atom (P "p"), Atom (P "q"))++-- ------------------------------------------------------------------------- +-- Surprising tautologies including Dijkstra's "Golden rule".                +-- ------------------------------------------------------------------------- ++test15 :: Test+test15 = TestCase $ assertEqual "tautology 5 (p. 43)" expected input+    where input = tautology $ (p .=>. q) .|. (q .=>. p)+          expected = True+          (p, q) = (Atom (P "p"), Atom (P "q"))+test16 :: Test+test16 = TestCase $ assertEqual "tautology 6 (p. 45)" expected input+    where input = tautology $ p .|. (q .<=>. r) .<=>. (p .|. q .<=>. p .|. r)+          expected = True+          (p, q, r) = (Atom (P "p"), Atom (P "q"), Atom (P "r"))+test17 :: Test+test17 = TestCase $ assertEqual "Dijkstra's Golden Rule (p. 45)" expected input+    where input = tautology $ p .&. q .<=>. ((p .<=>. q) .<=>. p .|. q)+          expected = True+          (p, q) = (Atom (P "p"), Atom (P "q"))+test18 :: Test+test18 = TestCase $ assertEqual "Contraposition 1 (p. 46)" expected input+    where input = tautology $ (p .=>. q) .<=>. (((.~.)q) .=>. ((.~.)p))+          expected = True+          (p, q) = (Atom (P "p"), Atom (P "q"))+test19 :: Test+test19 = TestCase $ assertEqual "Contraposition 2 (p. 46)" expected input+    where input = tautology $ (p .=>. ((.~.)q)) .<=>. (q .=>. ((.~.)p))+          expected = True+          (p, q) = (Atom (P "p"), Atom (P "q"))+test20 :: Test+test20 = TestCase $ assertEqual "Contraposition 3 (p. 46)" expected input+    where input = tautology $ (p .=>. q) .<=>. (q .=>. p)+          expected = False+          (p, q) = (Atom (P "p"), Atom (P "q"))++-- ------------------------------------------------------------------------- +-- Some logical equivalences allowing elimination of connectives.            +-- ------------------------------------------------------------------------- ++test21 :: Test+test21 = TestCase $ assertEqual "Equivalences (p. 47)" expected input+    where input =+              map tautology+              [ true .<=>. false .=>. false+              , ((.~.)p) .<=>. p .=>. false+              , p .&. q .<=>. (p .=>. q .=>. false) .=>. false+              , p .|. q .<=>. (p .=>. false) .=>. q+              , (p .<=>. q) .<=>. ((p .=>. q) .=>. (q .=>. p) .=>. false) .=>. false ]+          expected = [True, True, True, True, True]+          (p, q) = (Atom (P "p"), Atom (P "q"))++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test22 :: Test+test22 = TestCase $ assertEqual "Dual (p. 49)" expected input+    where input = dual (Atom (P "p") .|. ((.~.) (Atom (P "p"))))+          expected = And (Atom (P {pname = "p"})) (Not (Atom (P {pname = "p"})))++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test23 :: Test+test23 = TestCase $ assertEqual "psimplify 1 (p. 50)" expected input+    where input = psimplify $ (true .=>. (x .<=>. false)) .=>. ((.~.) (y .|. false .&. z))+          expected = ((.~.) x) .=>. ((.~.) y)+          x = Atom (P "x")+          y = Atom (P "y")+          z = Atom (P "z")++test24 :: Test+test24 = TestCase $ assertEqual "psimplify 2 (p. 51)" expected input+    where input = psimplify $ ((x .=>. y) .=>. true) .|. (.~.) false+          expected = true+          x = Atom (P "x")+          y = Atom (P "y")++-- ------------------------------------------------------------------------- +-- Example of NNF function in action.                                        +-- ------------------------------------------------------------------------- ++test25 :: Test+test25 = TestCase $ assertEqual "nnf 1 (p. 53)" expected input+    where input = nnf $ (p .<=>. q) .<=>. ((.~.)(r .=>. s))+          expected = Or (And (Or (And p q) (And (Not p) (Not q)))+                        (And r (Not s)))+                        (And (Or (And p (Not q)) (And (Not p) q))+                             (Or (Not r) s))+          p = Atom (P "p")+          q = Atom (P "q")+          r = Atom (P "r")+          s = Atom (P "s")++test26 :: Test+test26 = TestCase $ assertEqual "nnf 1 (p. 53)" expected input+    where input = tautology (Iff fm fm')+          expected = True+          fm' = nnf fm+          fm = (p .<=>. q) .<=>. ((.~.)(r .=>. s))+          p = Atom (P "p")+          q = Atom (P "q")+          r = Atom (P "r")+          s = Atom (P "s")++-- ------------------------------------------------------------------------- +-- Some tautologies remarked on.                                             +-- ------------------------------------------------------------------------- ++test27 :: Test+test27 = TestCase $ assertEqual "tautology 1 (p. 53)" expected input+    where input = tautology $ (p .=>. p') .&. (q .=>. q') .=>. (p .&. q .=>. p' .&. q')+          expected = True+          p = Atom (P "p")+          q = Atom (P "q")+          p' = Atom (P "p'")+          q' = Atom (P "q'")+test28 :: Test+test28 = TestCase $ assertEqual "nnf 1 (p. 53)" expected input+    where input = tautology $ (p .=>. p') .&. (q .=>. q') .=>. (p .|. q .=>. p' .|. q')+          expected = True+          p = Atom (P "p")+          q = Atom (P "q")+          p' = Atom (P "p'")+          q' = Atom (P "q'")++-- ------------------------------------------------------------------------- +-- Examples.                                                                 +-- ------------------------------------------------------------------------- ++test29 :: Test+test29 = TestCase $ assertEqual "dnf 1 (p. 56)" expected input+    where input = (dnf fm, truthTable fm)+          expected = (Or (And (Not r) p) (And r (And (Not p) q)),+                      [([(P {pname = "p"},False),(P {pname = "q"},False),(P {pname = "r"},False)],False),+                       ([(P {pname = "p"},False),(P {pname = "q"},False),(P {pname = "r"},True)],False),+                       ([(P {pname = "p"},False),(P {pname = "q"},True),(P {pname = "r"},False)],False),+                       ([(P {pname = "p"},False),(P {pname = "q"},True),(P {pname = "r"},True)],True),+                       ([(P {pname = "p"},True),(P {pname = "q"},False),(P {pname = "r"},False)],True),+                       ([(P {pname = "p"},True),(P {pname = "q"},False),(P {pname = "r"},True)],False),+                       ([(P {pname = "p"},True),(P {pname = "q"},True),(P {pname = "r"},False)],True),+                       ([(P {pname = "p"},True),(P {pname = "q"},True),(P {pname = "r"},True)],False)])+          fm = (p .|. q .&. r) .&. (((.~.)p) .|. ((.~.)r))+          p = Atom (P "p")+          q = Atom (P "q")+          r = Atom (P "r")++test30 :: Test+test30 = TestCase $ assertEqual "dnf 2 (p. 56)" expected input+    where input = dnf (p .&. q .&. r .&. s .&. t .&. u .|. u .&. v :: Formula Prop)+          expected = (v .&. u) .|. (q .&. (r .&. (s .&. (t .&. ((u .&. p))))))+          p = Atom (P "p")+          q = Atom (P "q")+          r = Atom (P "r")+          s = Atom (P "s")+          t = Atom (P "t")+          u = Atom (P "u")+          v = Atom (P "v")++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test31 :: Test+test31 = TestCase $ assertEqual "rawdnf (p. 58)" expected input+    where input = rawdnf $ (p .|. q .&. r) .&. (((.~.)p) .|. ((.~.)r))+          expected = ((atomic (P "p")) .&. ((.~.)(atomic (P "p"))) .|.+                      ((atomic (P "q")) .&. (atomic (P "r"))) .&. ((.~.)(atomic (P "p")))) .|.+                     ((atomic (P "p")) .&. ((.~.)(atomic (P "r"))) .|.+                      ((atomic (P "q")) .&. (atomic (P "r"))) .&. ((.~.)(atomic (P "r"))))+          (p, q, r) = (Atom (P "p"), Atom (P "q"), Atom (P "r"))++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test32 :: Test+test32 = TestCase $ assertEqual "purednf (p. 58)" expected input+    where input = purednf $ (p .|. q .&. r) .&. (((.~.)p) .|. ((.~.)r))+          expected = Set.fromList [Set.fromList [p,Not p],+                                   Set.fromList [p,Not r],+                                   Set.fromList [q,r,Not p],+                                   Set.fromList [q,r,Not r]]+          p = Atom (P "p")+          q = Atom (P "q")+          r = Atom (P "r")++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test33 :: Test+test33 = TestCase $ assertEqual "trivial" expected input+    where input = Set.filter (not . trivial) (purednf fm)+          expected = Set.fromList [Set.fromList [p,Not r],+                                   Set.fromList [q,r,Not p]]+          fm = (p .|. q .&. r) .&. (((.~.)p) .|. ((.~.)r))+          p = Atom (P "p")+          q = Atom (P "q")+          r = Atom (P "r")++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test34 :: Test+test34 = TestCase $ assertEqual "dnf" expected input+    where input = (dnf fm, tautology (Iff fm (dnf fm)))+          expected = (Or (And (Not r) p) (And r (And (Not p) q)), True)+          fm = (p .|. q .&. r) .&. (((.~.)p) .|. ((.~.)r))+          p = Atom (P "p")+          q = Atom (P "q")+          r = Atom (P "r")++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test35 :: Test+test35 = TestCase $ assertEqual "cnf" expected input+    where input = (cnf fm, tautology (Iff fm (cnf fm)))+          -- Fully parenthesized+          -- expected = (((atomic (P "r")) .|. (atomic (P "p"))) .&. (((((.~.)(atomic (P "r")))) .|. (((.~.)(atomic (P "p"))))) .&. ((atomic (P "q")) .|. (atomic (P "p")))),True)+          -- Edited+          expected = (   ((atomic (P "r"))           .|. (atomic (P "p")))          .&.+                      (  (((.~.)(atomic (P "r")))   .|. ((.~.)(atomic (P "p"))))    .&.+                         ((atomic (P "q"))          .|. (atomic (P "p")))            ),+                      True)+          -- expected = (And (Or q p) (And (Or r p) (Or (Not r) (Not p))),True)+          -- expected = (F, True)+          -- expected = (((atomic (P "r")) .|. (atomic (P "p"))) .&. (((((.~.)(atomic (P "r"))))) .|. ((((.~.)(atomic (P "p"))))) .&. (atomic (P "q")) .|. (atomic (P "p"))),True)+          fm = (p .|. q .&. r) .&. (((.~.)p) .|. ((.~.)r))+          p = Atom (P "p")+          q = Atom (P "q")+          r = Atom (P "r")
+ Data/Logic/Tests/Harrison/Resolution.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}+module Data.Logic.Tests.Harrison.Resolution where++import Control.Applicative.Error (Failing(..))+import Data.Logic.Classes.Combine (Combinable(..))+import Data.Logic.Classes.Equals (pApp)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..))+import Data.Logic.Classes.Negate ((.~.))+import Data.Logic.Classes.Term (Term(vt, fApp))+import Data.Logic.Harrison.Normal (simpcnf)+import Data.Logic.Harrison.Resolution (resolution1, resolution2, presolution)+import Data.Logic.Harrison.Skolem (runSkolem, skolemize)+import Data.Logic.Harrison.Tableaux (unifyAtomsEq)+import Data.Logic.Types.Harrison.Equal (FOLEQ)+import Data.Logic.Types.Harrison.FOL (Function(Skolem))+import Data.Logic.Types.Harrison.Formulas.FirstOrder (Formula)+import qualified Data.Set as Set+import Data.String (IsString(..))+import Prelude hiding (negate)+-- import Test.HUnit (Test(TestCase, TestList, TestLabel), assertEqual, Assertion)+import Data.Logic.Tests.Harrison.HUnit++tests :: Test (Formula FOLEQ)+tests = TestLabel "Data.Logic.Tests.Harrison.Resolution" $ TestList [test01, test02, test03, test04]++-- ------------------------------------------------------------------------- +-- Barber's paradox is an example of why we need factoring.                  +-- ------------------------------------------------------------------------- ++test01 :: Test (Formula FOLEQ)+test01 = TestCase $ assertEqual "Barber's paradox (p. 181)" expected input+    where input = simpcnf (runSkolem (skolemize ((.~.)barb)))+          barb :: Formula FOLEQ+          barb = exists (fromString "b") (for_all (fromString "x") (shaves [b, x] .<=>. ((.~.)(shaves [x, x]))))+          -- This is not exactly what is in the book+          expected = Set.fromList [Set.fromList [shaves [b,     fx [b]], (.~.)(shaves [fx [b],fx [b]])],+                                   Set.fromList [shaves [fx [b],fx [b]], (.~.)(shaves [b,     fx [b]])]]+          x = vt (fromString "x")+          b = vt (fromString "b")+          fx = fApp (Skolem 1)+          shaves = pApp (fromString "shaves") ++-- ------------------------------------------------------------------------- +-- Simple example that works well.                                           +-- ------------------------------------------------------------------------- ++test02 :: Test (Formula FOLEQ)+test02 = TestCase $ assertEqual "Davis-Putnam example" expected input+    where input = runSkolem (resolution1 unifyAtomsEq (dpExampleFm :: Formula FOLEQ))+          expected = Set.singleton (Success True)++dpExampleFm :: Formula FOLEQ+dpExampleFm = exists x . exists y .for_all z $+              (f [vt x, vt y] .=>. (f [vt y, vt z] .&. f [vt z, vt z])) .&.+              ((f [vt x, vt y] .&. g [vt x, vt y]) .=>. (g [vt x, vt z] .&. g [vt z, vt z]))+    where+      x = fromString "x"+      y = fromString "y"+      z = fromString "z"+      g = pApp (fromString "G")+      f = pApp (fromString "F")++-- ------------------------------------------------------------------------- +-- This is now a lot quicker.                                                +-- ------------------------------------------------------------------------- ++test03 :: Test (Formula FOLEQ)+test03 = TestCase $ assertEqual "Davis-Putnam example 2" expected input+    where input = runSkolem (resolution2 (dpExampleFm :: Formula FOLEQ))+          expected = Set.singleton (Success True)++-- ------------------------------------------------------------------------- +-- Example: the (in)famous Los problem.                                      +-- ------------------------------------------------------------------------- ++test04 :: Test (Formula FOLEQ)+test04 = TestCase $ assertEqual "Los problem (p. 198)" expected input+    where input = runSkolem (presolution losFm)+          expected = Set.fromList [Success True]++losFm :: Formula FOLEQ+losFm = (for_all x (for_all y (for_all z (p [vt x, vt y] .=>. p [vt y, vt z] .=>. p [vt x, vt z])))) .&.+        (for_all x (for_all y (for_all z (q [vt x, vt y] .=>. q [vt y, vt z] .=>. q [vt x, vt z])))) .&.+        (for_all x (for_all y (q [vt x, vt y] .=>. q [vt y, vt x]))) .&.+        (for_all x (for_all y (p [vt x, vt y] .|. q [vt x, vt y]))) .=>.+        (for_all x (for_all y (p [vt x, vt y]))) .|.+        (for_all x (for_all y (q [vt x, vt y])))+    where+      x = fromString "x"+      y = fromString "y"+      z = fromString "z"+      p = pApp (fromString "P")+      q = pApp (fromString "Q")
+ Data/Logic/Tests/Harrison/Skolem.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings, RankNTypes, ScopedTypeVariables, TypeFamilies #-}+{-# OPTIONS_GHC -Wall #-}+module Data.Logic.Tests.Harrison.Skolem+    ( tests+    ) where++import Data.Logic.Classes.Combine (Combinable(..))+import Data.Logic.Classes.Constants (false)+import Data.Logic.Classes.Equals (pApp)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(exists, for_all))+import Data.Logic.Classes.Negate ((.~.))+import Data.Logic.Classes.Term (Term(..))+import Data.Logic.Harrison.Skolem (simplify, nnf, pnf)+import Data.Logic.Harrison.Skolem (runSkolem, skolemize)+import Data.Logic.Tests.Harrison.HUnit ()+import Data.Logic.Types.Harrison.Equal (FOLEQ, PredName(..))+import Data.Logic.Types.Harrison.FOL (Function(..))+import Data.Logic.Types.Harrison.Formulas.FirstOrder (Formula)+import Test.HUnit (Test(TestCase, TestList, TestLabel), assertEqual)++tests :: Test+tests = TestLabel "Data.Logic.Tests.Harrison.Skolem" $ TestList [test01, test02, test03, test04, test05]++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test01 :: Test+test01 = TestCase $ assertEqual "simplify (p. 140)" expected input+    where p = Named "P"+          q = Named "Q"+          input = simplify fm+          expected = (for_all "x" (pApp p [vt "x"])) .=>. (pApp q []) :: Formula FOLEQ+          fm :: Formula FOLEQ+          fm = (for_all "x" (for_all "y" (pApp p [vt "x"] .|. (pApp p [vt "y"] .&. false)))) .=>. exists "z" (pApp q [])++-- ------------------------------------------------------------------------- +-- Example of NNF function in action.                                        +-- ------------------------------------------------------------------------- ++test02 :: Test+test02 = TestCase $ assertEqual "nnf (p. 140)" expected input+    where p = Named "P"+          q = Named "Q"+          input = nnf fm+          expected = exists "x" ((.~.)(pApp p [vt "x"])) .|.+                     ((exists "y" (pApp q [vt "y"]) .&. exists "z" ((pApp p [vt "z"]) .&. (pApp q [vt "z"]))) .|.+                      (for_all "y" ((.~.)(pApp q [vt "y"])) .&.+                       for_all "z" (((.~.)(pApp p [vt "z"])) .|. ((.~.)(pApp q [vt "z"])))))+          fm :: Formula FOLEQ+          fm = (for_all "x" (pApp p [vt "x"])) .=>. ((exists "y" (pApp q [vt "y"])) .<=>. exists "z" (pApp p [vt "z"] .&. pApp q [vt "z"]))++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test03 :: Test+test03 = TestCase $ assertEqual "pnf (p. 144)" expected input+    where p = Named "P"+          q = Named "Q"+          r = Named "R"+          input = pnf fm+          expected = exists "x" (for_all "z"+                                 ((((.~.)(pApp p [vt "x"])) .&. ((.~.)(pApp r [vt "y"]))) .|.+                                  ((pApp q [vt "x"]) .|.+                                   (((.~.)(pApp p [vt "z"])) .|.+                                    ((.~.)(pApp q [vt "z"]))))))+          fm :: Formula FOLEQ+          fm = (for_all "x" (pApp p [vt "x"]) .|. (pApp r [vt "y"])) .=>.+               exists "y" (exists "z" ((pApp q [vt "y"]) .|. ((.~.)(exists "z" (pApp p [vt "z"] .&. pApp q [vt "z"])))))++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test04 :: Test+test04 = TestCase $ assertEqual "skolemize 1 (p. 150)" expected input+    where input = runSkolem $ skolemize fm+          fm :: Formula FOLEQ+          fm = exists "y" (pApp (Named "<") [vt "x", vt "y"] .=>.+                           for_all "u" (exists "v" (pApp (Named "<") [fApp "*" [vt "x", vt "u"],  fApp "*" [vt "y", vt "v"]])))+          expected = ((.~.)(pApp (Named "<") [vt "x",fApp (Skolem 1) [vt "x"]])) .|.+                     (pApp (Named "<") [fApp "*" [vt "x",vt "u"],fApp "*" [fApp (Skolem 1) [vt "x"],fApp (Skolem 2) [vt "u",vt "x"]]])++test05 :: Test+test05 = TestCase $ assertEqual "skolemize 2 (p. 150)" expected input+    where p = Named "P"+          q = Named "Q"+          input = runSkolem $ skolemize fm+          fm :: Formula FOLEQ+          fm = for_all "x" ((pApp p [vt "x"]) .=>.+                            (exists "y" (exists "z" ((pApp q [vt "y"]) .|.+                                                     ((.~.)(exists "z" ((pApp p [vt "z"]) .&. (pApp q [vt "z"]))))))))+          expected = ((.~.)(pApp p [vt "x"])) .|.+                     ((pApp q [fApp (Skolem 1) []]) .|.+                      (((.~.)(pApp p [vt "z"])) .|.+                       ((.~.)(pApp q [vt "z"]))))
+ Data/Logic/Tests/Harrison/Unif.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall -Wwarn #-}+module Data.Logic.Tests.Harrison.Unif+    ( tests+    ) where++import Control.Applicative.Error (Failing(..), failing)+import Data.Logic.Classes.Term (Term(fApp, vt), tsubst)+import Data.Logic.Harrison.Unif (fullUnify)+import Data.Logic.Types.Harrison.FOL (TermType)+import Data.Logic.Tests.Harrison.HUnit ()+import Test.HUnit (Test(TestCase, TestList, TestLabel), assertEqual)++tests :: Test+tests = TestLabel "Data.Logic.Tests.Harrison.Unif" $ TestList [test01]++-- ------------------------------------------------------------------------- +-- Examples.                                                                 +-- ------------------------------------------------------------------------- ++test01 :: Test+test01 = TestCase $ assertEqual "Unify tests" expected input+    where input = map unify_and_apply eqss+          expected = map Success $+                      [[(fApp "f" [fApp "f" [vt "z"],fApp "g" [vt "y"]],+                        fApp "f" [fApp "f" [vt "z"],fApp "g" [vt "y"]])],+                      [(fApp "f" [vt "y",vt "y"],fApp "f" [vt "y",vt "y"])],+                      [(fApp "f" [fApp "f" [fApp "f" [vt "x3",vt "x3"],fApp "f" [vt "x3",vt "x3"]],+                                  fApp "f" [fApp "f" [vt "x3",vt "x3"],fApp "f" [vt "x3",vt "x3"]]],+                        fApp "f" [fApp "f" [fApp "f" [vt "x3",vt "x3"],fApp "f" [vt "x3",vt "x3"]],+                                  fApp "f" [fApp "f" [vt "x3",vt "x3"],fApp "f" [vt "x3",vt "x3"]]]),+                       (fApp "f" [fApp "f" [vt "x3",vt "x3"],fApp "f" [vt "x3",vt "x3"]],+                        fApp "f" [fApp "f" [vt "x3",vt "x3"],fApp "f" [vt "x3",vt "x3"]]),+                       (fApp "f" [vt "x3",vt "x3"],+                        fApp "f" [vt "x3",vt "x3"])]]+          unify_and_apply eqs =+              mapM app eqs+              where+                app (t1, t2) = failing Failure (\ i -> Success (tsubst i t1, tsubst i t2)) (fullUnify eqs)+          eqss :: [[(TermType, TermType)]]+          eqss =  [ [(fApp "f" [vt "x", fApp "g" [vt "y"]], fApp "f" [fApp "f" [vt "z"], vt "w"])]+                  , [(fApp "f" [vt "x", vt "y"], fApp "f" [vt "y", vt "x"])]+                  -- , [(fApp "f" [vt "x", fApp "g" [vt "y"]], fApp "f" [vt "y", vt "x"])] -- cyclic+                  , [(vt "x0", fApp "f" [vt "x1", vt "x1"]),+                     (vt "x1", fApp "f" [vt "x2", vt "x2"]),+                     (vt "x2", fApp "f" [vt "x3", vt "x3"])] ]
+ Data/Logic/Tests/Logic.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings,+             ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances #-}+{-# OPTIONS -Wall -Wwarn -fno-warn-name-shadowing -fno-warn-orphans #-}+module Data.Logic.Tests.Logic (tests) where++import Data.Logic.Classes.Arity (Arity(arity))+import Data.Logic.Classes.Combine (Combinable(..))+import Data.Logic.Classes.Constants (Constants(..))+import Data.Logic.Classes.Equals (AtomEq, (.=.), pApp, pApp1, showAtomEq)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), showFirstOrder)+import Data.Logic.Classes.Formula (Formula)+import Data.Logic.Classes.Literal (Literal)+import Data.Logic.Classes.Negate (negated, (.~.))+import Data.Logic.Classes.Skolem (Skolem(..))+import Data.Logic.Classes.Term (Term(..))+import Data.Logic.Classes.Variable (Variable)+import Data.Logic.Harrison.FOL (fv, subst)+import Data.Logic.Normal.Clause (clauseNormalForm)+import Data.Logic.Normal.Implicative (runNormal)+import Data.Logic.Satisfiable (theorem, inconsistant)+import Data.Logic.Tests.Common (TFormula, TTerm, myTest)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.String (IsString(fromString))+import PropLogic (PropForm(..), TruthTable, truthTable)+import qualified TextDisplay as TD+import Test.HUnit++-- |Don't use this at home!  It breaks type safety, fromString "True"+-- fromBool True.+instance Constants String where+    fromBool = show++tests :: Test+tests = TestLabel "Test.Logic" $ TestList (precTests ++ theoremTests)++{-+formCase :: (FirstOrderFormula TFormula TAtom V, AtomEq TAtom Pr TTerm, Term TTerm V AtomicFunction) =>+            String -> TFormula -> TFormula -> Test+formCase s expected input = TestLabel s $ TestCase (assertEqual s expected input)+-}++precTests :: [Test]+precTests =+    [ myTest "Logic - prec test 1"+               ((a .&. b) .|. c)+               (a .&. b .|. c)+      -- You can't apply .~. without parens:+      -- :type (.~. a)   -> (FormulaPF -> t) -> t+      -- :type ((.~.) a) -> FormulaPF+    , myTest "Logic - prec test 2"+               (((.~.) a) .&. b)+               ((.~.) a .&. b :: TFormula)+    -- I switched the precedence of .&. and .|. from infixl to infixr to get+    -- some of the test cases to match the answers given on the miami.edu site,+    -- but maybe I should switch them back and adjust the answer given in the+    -- test case.+    , myTest "Logic - prec test 3"+               ((a .&. b) .&. c) -- infixl, with infixr we get (a .&. (b .&. c))+               (a .&. b .&. c :: TFormula)+    , TestCase (assertEqual "Logic - Find a free variable"+                (fv (for_all "x" (x .=. y) :: TFormula))+                (Set.singleton "y"))+    , TestCase (assertEqual "Logic - Substitute a variable"+                (map sub+                         [ for_all "x" (x .=. y) {- :: Formula String String -}+                         , for_all "y" (x .=. y) {- :: Formula String String -} ])+                [ for_all "x" (x .=. z) :: TFormula+                , for_all "y" (z .=. y) :: TFormula ])+    ]+    where+      sub f = subst (Map.singleton (head . Set.toList . fv $ f) (vt "z")) f+      a = pApp ("a") []+      b = pApp ("b") []+      c = pApp ("c") []++x :: TTerm+x = vt (fromString "x")+y :: TTerm+y = vt (fromString "y")+z :: TTerm+z = vt (fromString "z")++-- |Here is an example of automatic conversion from a FirstOrderFormula+-- instance to a PropositionalFormula instance.  The result is PropForm+-- a where a is the original type, but the a values will always be+-- "atomic" formulas, never the operators which can be converted into+-- the corresponding operator of a PropositionalFormula instance.+{-+test9a :: Test+test9a = TestCase +           (assertEqual "Logic - convert to PropLogic"+            expected+            (flatten (cnf' (for_all "x" (for_all "y" (q [x, y] .<=>. for_all "z" (f [z, x] .<=>. f [z, y])))))))+    where+      f = pApp "f"+      q = pApp "q"+      expected :: PropForm TFormula+      expected = CJ [DJ [N (A (pApp ("q") [vt (V "x"),vt (V "y")])),+                         N (A (pApp ("f") [vt (V "z"),vt (V "x")])),+                         A (pApp ("f") [vt (V "z"),vt (V "y")])],+                     DJ [N (A (pApp ("q") [vt (V "x"),vt (V "y")])),+                         N (A (pApp ("f") [vt (V "z"),vt (V "y")])),+                         A (pApp ("f") [vt (V "z"),vt (V "x")])],+                     DJ [A (pApp ("f") [fApp (Skolem 1) [vt (V "x"),vt (V "y"),vt (V "z")],vt (V "x")]),+                         A (pApp ("f") [fApp (Skolem 1) [vt (V "x"),vt (V "y"),vt (V "z")],vt (V "y")]),+                         A (pApp ("q") [vt (V "x"),vt (V "y")])],+                     DJ [N (A (pApp ("f") [fApp (Skolem 1) [vt (V "x"),vt (V "y"),vt (V "z")],vt (V "y")])),+                         A (pApp ("f") [fApp (Skolem 1) [vt (V "x"),vt (V "y"),vt (V "z")],vt (V "y")]),+                         A (pApp ("q") [vt (V "x"),vt (V "y")])],+                     DJ [A (pApp ("f") [fApp (Skolem 1) [vt (V "x"),vt (V "y"),vt (V "z")],vt (V "x")]),+                         N (A (pApp ("f") [fApp (Skolem 1) [vt (V "x"),vt (V "y"),vt (V "z")],vt (V "x")])),+                         A (pApp ("q") [vt (V "x"),vt (V "y")])],+                     DJ [N (A (pApp ("f") [fApp (Skolem 1) [vt (V "x"),vt (V "y"),vt (V "z")],vt (V "y")])),+                         N (A (pApp ("f") [fApp (Skolem 1) [vt (V "x"),vt (V "y"),vt (V "z")],vt (V "x")])),+                         A (pApp ("q") [vt (V "x"),vt (V "y")])]]++moveQuantifiersOut1 :: Test+moveQuantifiersOut1 =+    myTest "Logic - moveQuantifiersOut1"+             (for_all "x2" ((pApp ("p") [vt ("x2")]) .&. ((pApp ("q") [vt ("x")]))))+             (prenexNormalForm (for_all "x" (pApp (fromString "p") [x]) .&. (pApp (fromString "q") [x])))++skolemize1 :: Test+skolemize1 =+    myTest "Logic - skolemize1" expected formula+    where+      expected :: TFormula+      expected = for_all [V "y",V "z"] (for_all [V "v"] (pApp "P" [fApp (toSkolem 1) [], y, z, fApp ((toSkolem 2)) [y, z], v, fApp (toSkolem 3) [y, z, v]]))+      formula :: TFormula+      formula = (snf' (exists ["x"] (for_all ["y", "z"] (exists ["u"] (for_all ["v"] (exists ["w"] (pApp "P" [x, y, z, u, v, w])))))))++skolemize2 :: Test+skolemize2 =+    myTest "Logic - skolemize2" expected formula+    where+      expected :: TFormula+      expected = for_all [V "y"] (pApp ("loves") [fApp (toSkolem 1) [],y])+      formula :: TFormula+      formula = snf' (exists ["x"] (for_all ["y"] (pApp "loves" [x, y])))++skolemize3 :: Test+skolemize3 =+    myTest "Logic - skolemize3" expected formula+    where+      expected :: TFormula+      expected = for_all [V "y"] (pApp ("loves") [fApp (toSkolem 1) [y],y])+      formula :: TFormula+      formula = snf' (for_all ["y"] (exists ["x"] (pApp "loves" [x, y])))+-}+{-+inf1 :: Test+inf1 =+    myTest "Logic - inf1" expected formula+    where+      expected :: TFormula+      expected = ((pApp ("p") [vt ("x")]) .=>. (((pApp ("q") [vt ("x")]) .|. ((pApp ("r") [vt ("x")])))))+      formula :: {- ImplicativeNormalFormula inf (C.Sentence V String AtomicFunction) (C.Term V AtomicFunction) V String AtomicFunction => -} TFormula+      formula = convertFOF id id id (implicativeNormalForm (convertFOF id id id (for_all ["x"] (p [x] .=>. (q [x] .|. r [x]))) :: C.Sentence V String AtomicFunction) :: C.Sentence V String AtomicFunction)+-}++instance Arity String where+    arity _ = Nothing++theoremTests :: [Test]+theoremTests =+    let s = pApp "S"+        h = pApp "H"+        m = pApp "M" in+    [ let formula = for_all "x" (((s [x] .=>. h [x]) .&. (h [x] .=>. m [x])) .=>.+                                  (s [x] .=>. m [x])) in+      myTest "Logic - theorem test 1"+                (True,([],Just (CJ []),[([],True)]))+{-+                (True,+                 ([(pApp ("H") [vt (V "x")]),(pApp ("M") [vt (V "x")]),(pApp ("S") [vt (V "x")])],+                  Just (CJ [DJ [A (pApp ("S") [vt (V "x")]),+                                A (pApp ("H") [vt (V "x")]),+                                N (A (pApp ("S") [vt (V "x")])),+                                A (pApp ("M") [vt (V "x")])],+                            DJ [N (A (pApp ("H") [vt (V "x")])),+                                A (pApp ("H") [vt (V "x")]),+                                N (A (pApp ("S") [vt (V "x")])),+                                A (pApp ("M") [vt (V "x")])],+                            DJ [A (pApp ("S") [vt (V "x")]),+                                N (A (pApp ("M") [vt (V "x")])),+                                N (A (pApp ("S") [vt (V "x")])),+                                A (pApp ("M") [vt (V "x")])],+                            DJ [N (A (pApp ("H") [vt (V "x")])),+                                N (A (pApp ("M") [vt (V "x")])),+                                N (A (pApp ("S") [vt (V "x")])),+                                A (pApp ("M") [vt (V "x")])]]),+                  [([False,False,False],True),+                   ([False,False,True],True),+                   ([False,True,False],True),+                   ([False,True,True],True),+                   ([True,False,False],True),+                   ([True,False,True],True),+                   ([True,True,False],True),+                   ([True,True,True],True)]))+-}+                (runNormal (theorem formula), table formula)+    , myTest "Logic - theorem test 1a"+                (False,+                 False,+                 ([(pApp1 ("H") (fApp (toSkolem 1) [])),+                   (pApp1 ("M") (vt ("y"))),+                   (pApp1 ("M") (fApp (toSkolem 1) [])),+                   (pApp1 ("S") (vt ("y"))),+                   (pApp1 ("S") (fApp (toSkolem 1) []))],+                  Just (CJ [DJ [A (pApp1 ("H") (fApp (toSkolem 1) [])),+                                A (pApp1 ("M") (vt ("y"))),+                                A (pApp1 ("S") (fApp (toSkolem 1) [])),+                                N (A (pApp1 ("S") (vt ("y"))))],+                            DJ [A (pApp1 ("M") (vt ("y"))),+                                A (pApp1 ("S") (fApp (toSkolem 1) [])),+                                N (A (pApp1 ("M") (fApp (toSkolem 1) []))),+                                N (A (pApp1 ("S") (vt ("y"))))],+                            DJ [A (pApp1 ("M") (vt ("y"))),+                                N (A (pApp1 ("H") (fApp (toSkolem 1) []))),+                                N (A (pApp1 ("M") (fApp (toSkolem 1) []))),+                                N (A (pApp1 ("S") (vt ("y"))))]]),+                  [([False,False,False,False,False],True),+                   ([False,False,False,False,True],True),+                   ([False,False,False,True,False],False),+                   ([False,False,False,True,True],True),+                   ([False,False,True,False,False],True),+                   ([False,False,True,False,True],True),+                   ([False,False,True,True,False],False),+                   ([False,False,True,True,True],True),+                   ([False,True,False,False,False],True),+                   ([False,True,False,False,True],True),+                   ([False,True,False,True,False],True),+                   ([False,True,False,True,True],True),+                   ([False,True,True,False,False],True),+                   ([False,True,True,False,True],True),+                   ([False,True,True,True,False],True),+                   ([False,True,True,True,True],True),+                   ([True,False,False,False,False],True),+                   ([True,False,False,False,True],True),+                   ([True,False,False,True,False],True),+                   ([True,False,False,True,True],True),+                   ([True,False,True,False,False],True),+                   ([True,False,True,False,True],True),+                   ([True,False,True,True,False],False),+                   ([True,False,True,True,True],False),+                   ([True,True,False,False,False],True),+                   ([True,True,False,False,True],True),+                   ([True,True,False,True,False],True),+                   ([True,True,False,True,True],True),+                   ([True,True,True,False,False],True),+                   ([True,True,True,False,True],True),+                   ([True,True,True,True,False],True),+                   ([True,True,True,True,True],True)]))+                +                (let formula = (for_all "x" ((s [x] .=>. h [x]) .&. (h [x] .=>. m [x]))) .=>.+                               (for_all "y" (s [y] .=>. m [y])) in+                 (runNormal (theorem formula), runNormal (inconsistant formula), table formula))+                +    , myTest "Logic - socrates is mortal, truth table"+                ([(pApp1 ("H") (vt ("x"))),+                  (pApp1 ("M") (vt ("x"))),+                  (pApp1 ("S") (vt ("x")))],+                 Just (CJ [DJ [A (pApp1 ("H") (vt ("x"))),N (A (pApp1 ("S") (vt ("x"))))],+                           DJ [A (pApp1 ("M") (vt ("x"))),N (A (pApp1 ("H") (vt ("x"))))],+                           DJ [A (pApp1 ("M") (vt ("x"))),N (A (pApp1 ("S") (vt ("x"))))]]),+                 [([False,False,False],True),+                  ([False,False,True],False),+                  ([False,True,False],True),+                  ([False,True,True],False),+                  ([True,False,False],False),+                  ([True,False,True],False),+                  ([True,True,False],True),+                  ([True,True,True],True)])+                -- This formula has separate variables for each of the+                -- three beliefs.  To combine these into an argument+                -- we would wrap a single exists around them all and+                -- remove the existing ones, substituting that one+                -- variable into each formula.+                (table (for_all "x" (s [x] .=>. h [x]) .&.+                         for_all "y" (h [y] .=>. m [y]) .&.+                         for_all "z" (s [z] .=>. m [z])))++    , myTest "Logic - socrates is not mortal"+                (False,+                 False,+                 ([(pApp ("H") [vt ("x")]),+                   (pApp ("M") [vt ("x")]),+                   (pApp ("S") [vt ("x")]),+                   (pApp ("S") [fApp ("socrates") []])],+                  Just (CJ [DJ [A (pApp ("H") [vt ("x")]),N (A (pApp ("S") [vt ("x")]))],+                            DJ [A (pApp ("M") [vt ("x")]),N (A (pApp ("H") [vt ("x")]))],+                            DJ [A (pApp ("S") [fApp ("socrates") []])],+                            DJ [N (A (pApp ("M") [vt ("x")])),N (A (pApp ("S") [vt ("x")]))]]),+                  [([False,False,False,False],False),+                   ([False,False,False,True],True),+                   ([False,False,True,False],False),+                   ([False,False,True,True],False),+                   ([False,True,False,False],False),+                   ([False,True,False,True],True),+                   ([False,True,True,False],False),+                   ([False,True,True,True],False),+                   ([True,False,False,False],False),+                   ([True,False,False,True],False),+                   ([True,False,True,False],False),+                   ([True,False,True,True],False),+                   ([True,True,False,False],False),+                   ([True,True,False,True],True),+                   ([True,True,True,False],False),+                   ([True,True,True,True],False)]),+                 toSS [[(pApp ("H") [vt ("x")]),((.~.) (pApp ("S") [vt ("x")]))],+                       [(pApp ("M") [vt ("x")]),((.~.) (pApp ("H") [vt ("x")]))],+                       [(pApp ("S") [fApp ("socrates") []])],+                       [((.~.) (pApp ("M") [vt ("x")])),((.~.) (pApp ("S") [vt ("x")]))]])+                -- This represents a list of beliefs like those in our+                -- database: socrates is a man, all men are mortal,+                -- each with its own quantified variable.  In+                -- addition, we have an inconsistant belief, socrates+                -- is not mortal.  If we had a single variable this+                -- would be inconsistant, but as it stands it is an+                -- invalid argument, there are both 0 and 1 lines in+                -- the truth table.  If we go through the table and+                -- eliminate the lines where S(SkZ(x,y)) is true but M(SkZ(x,y)) is+                -- false (for any x) and those where H(x) is true but+                -- M(x) is false, the remaining lines would all be zero,+                -- the argument would be inconsistant (an anti-theorem.)+                -- How can we modify the formula to make these lines 0?+                (let (formula :: TFormula) =+                         for_all "x" ((s [x] .=>. h [x]) .&.+                                      (h [x] .=>. m [x]) .&.+                                      (m [x] .=>. ((.~.) (s [x])))) .&.+                         (s [fApp "socrates" []]) in+                 (runNormal (theorem formula), runNormal (inconsistant formula), table formula, runNormal (clauseNormalForm formula) :: Set.Set (Set.Set TFormula)))+    , let (formula :: TFormula) =+              (for_all "x" (pApp "L" [vt "x"] .=>. pApp "F" [vt "x"]) .&. -- All logicians are funny+               exists "x" (pApp "L" [vt "x"])) .=>.                            -- Someone is a logician+              (.~.) (exists "x" (pApp "F" [vt "x"]))                           -- Someone / Nobody is funny+          input = table formula+          expected = ([(pApp ("F") [vt ("x2")]),+                       (pApp ("F") [fApp (toSkolem 1) []]),+                       (pApp ("L") [vt ("x")]),+                       (pApp ("L") [fApp (toSkolem 1) []])],+                      Just (CJ [DJ [A (pApp1 ("L") (fApp (toSkolem 1) [])),N (A (pApp1 ("F") (vt ("x2")))),N (A (pApp1 ("L") (vt ("x"))))],+                                DJ [N (A (pApp1 ("F") (vt ("x2")))),N (A (pApp1 ("F") (fApp (toSkolem 1) []))),N (A (pApp1 ("L") (vt ("x"))))]]),+                      [([False,False,False,False],True),+                       ([False,False,False,True],True),+                       ([False,False,True,False],True),+                       ([False,False,True,True],True),+                       ([False,True,False,False],True),+                       ([False,True,False,True],True),+                       ([False,True,True,False],True),+                       ([False,True,True,True],True),+                       ([True,False,False,False],True),+                       ([True,False,False,True],True),+                       ([True,False,True,False],False),+                       ([True,False,True,True],True),+                       ([True,True,False,False],True),+                       ([True,True,False,True],True),+                       ([True,True,True,False],False),+                       ([True,True,True,True],False)])+      in myTest "Logic - gensler189" expected input+    , let (formula :: TFormula) =+              (for_all "x" (pApp "L" [vt "x"] .=>. pApp "F" [vt "x"]) .&. -- All logicians are funny+               exists "y" (pApp "L" [vt (fromString "y")])) .=>.           -- Someone is a logician+              (.~.) (exists "z" (pApp "F" [vt "z"]))                       -- Someone / Nobody is funny+          input = table formula+          expected :: TruthTable TFormula+          expected = ([(pApp1 ("F") (vt ("z"))),(pApp1 ("F") (fApp (toSkolem 1) [])),(pApp1 ("L") (vt ("y"))),(pApp1 ("L") (fApp (toSkolem 1) []))],Just (CJ [DJ [A (pApp1 ("L") (fApp (toSkolem 1) [])),N (A (pApp1 ("F") (vt ("z")))),N (A (pApp1 ("L") (vt ("y"))))],DJ [N (A (pApp1 ("F") (vt ("z")))),N (A (pApp1 ("F") (fApp (toSkolem 1) []))),N (A (pApp1 ("L") (vt ("y"))))]]),[([False,False,False,False],True),([False,False,False,True],True),([False,False,True,False],True),([False,False,True,True],True),([False,True,False,False],True),([False,True,False,True],True),([False,True,True,False],True),([False,True,True,True],True),([True,False,False,False],True),([True,False,False,True],True),([True,False,True,False],False),([True,False,True,True],True),([True,True,False,False],True),([True,True,False,True],True),([True,True,True,False],False),([True,True,True,True],False)])+      in myTest "Logic - gensler189 renamed" expected input+    ]++toSS :: Ord a => [[a]] -> Set.Set (Set.Set a)+toSS = Set.fromList . map Set.fromList++{-+theorem5 =+    myTest "Logic - theorm test 2"+              (Just True)+              (theorem ((.~.) ((for_all "x" (((s [x] .=>. h [x]) .&.+                                               (h [x] .=>. m [x]))) .&.+                                exists "x" (s [x] .&.+                                             ((.~.) (m [x])))))))+-}++instance TD.Display TFormula where+    textFrame x = [showFirstOrder showAtomEq x]+{-+    textFrame x = [quickShow x]+        where+          quickShow =+              foldF (\ _ -> error "Expecting atoms")+                    (\ _ _ _ -> error "Expecting atoms")+                    (\ _ _ _ -> error "Expecting atoms")+                    (\ t1 op t2 -> quickShowTerm t1 ++ quickShowOp op ++ quickShowTerm t2)+                    (\ p ts -> quickShowPred p ++ "(" ++ intercalate "," (map quickShowTerm ts) ++ ")")+          quickShowTerm =+              foldT quickShowVar+                    (\ f ts -> quickShowFn f ++ "(" ++ intercalate "," (map quickShowTerm ts) ++ ")")+          quickShowVar v = show v+          quickShowPred s = s+          quickShowFn (AtomicFunction s) = s+          quickShowOp (:=:) = "="+          quickShowOp (:!=:) = "!="+-}++{-+-- Truth table tests, find a more reasonable result value than [String].++(theorem1a, theorem1b, theorem1c, theorem1d) =+    ( myTest "Logic - truth table 1"+                (Just ["foo"])+                (prepare (for_all "x" (((s [x] .=>. h [x]) .&. (h [x] .=>. m [x])) .=>. (s [x] .=>. m [x]))) >>=+                 return . TD.textFrame . truthTable) )+    where s = pApp "S"+          h = pApp "H"+          m = pApp "M"++type FormulaPF = Formula String String+type F = PropForm FormulaPF++prepare :: FormulaPF -> F+prepare formula = ({- flatten . -} fromJust . toPropositional convertA . cnf . (.~.) $ formula)++convertA = Just . A+-}++table :: forall formula atom term v p f. (FirstOrderFormula formula atom v, Formula atom term v, AtomEq atom p term, Constants p, Eq p, Term term v f, Literal formula atom v,+                                     Ord formula, Skolem f, IsString v, Variable v, TD.Display formula) =>+         formula -> TruthTable formula+table f =+    -- truthTable :: Ord a => PropForm a -> TruthTable a+    tt cnf'+    where+      tt :: PropForm formula -> TruthTable formula+      tt = truthTable+      cnf' :: PropForm formula+      cnf' = CJ (map (DJ . map n) cnf)+      cnf :: [[formula]]+      cnf = fromSS (runNormal (clauseNormalForm f))+      fromSS = map Set.toList . Set.toList+      n f = (if negated f then N . A . (.~.) else A) $ f
+ Data/Logic/Tests/Main.hs view
@@ -0,0 +1,22 @@+import Data.Logic.Tests.Common (TestFormula, TestProof, V, TFormula, TAtom, TTerm)+import System.Exit+import Test.HUnit+import qualified Data.Logic.Tests.Harrison.Main as Harrison+import qualified Data.Logic.Tests.Logic as Logic+import qualified Data.Logic.Tests.Chiou0 as Chiou0+--import qualified Data.Logic.Tests.TPTP as TPTP+import qualified Data.Logic.Tests.Data as 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]) >>=+    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/Tests/TPTP.hs view
@@ -0,0 +1,22 @@+module Data.Logic.Tests.TPTP where+    +import Codec.TPTP (Formula)+import Data.Logic.FirstOrder (conj)+import Data.Logic.Instances.TPTP+import Data.Logic.Monad (runNormal)+import Data.Logic.Logic (Logic ((.~.), (.=>.)))+import Data.Logic.Normal (cnfTrace)+import Data.Logic.Test (TestFormula(formula))+import Test.Data (chang43KB, chang43Conjecture)+import Test.HUnit++tests :: Test+tests = TestLabel "Test.TPTP" $ TestList [tptp]++tptp :: Test+tptp =+    TestCase (assertEqual "tptp cnf trace" "abc" (runNormal (cnfTrace f)))+    where+      f :: Formula+      f = (.~.) (conj (map formula (snd (chang43KB :: (String, [TestFormula Formula])))) .=>.+                 formula chang43Conjecture)
Data/Logic/Types/FirstOrder.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies,-             GeneralizedNewtypeDeriving, MultiParamTypeClasses, TemplateHaskell, UndecidableInstances #-}+             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@@ -7,34 +7,47 @@ module Data.Logic.Types.FirstOrder     ( Formula(..)     , PTerm(..)+    , Predicate(..)     ) where  import Data.Data (Data) import Data.Logic.Classes.Arity (Arity)-import Data.Logic.Classes.Boolean (Boolean(..))-import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), showFirstOrder, Quant(..), Predicate(..))-import Data.Logic.Classes.Literal (Literal(..), PredicateLit(..))-import Data.Logic.Classes.Logic (Logic(..))-import Data.Logic.Classes.Negatable(Negatable(..))-import Data.Logic.Classes.Pred (Pred(..), pApp)-import Data.Logic.Classes.Propositional (Combine(..), BinOp(..))+import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..))+import Data.Logic.Classes.Constants (Constants(..), asBool)+import Data.Logic.Classes.Equals (AtomEq(..), (.=.), pApp, substAtomEq, varAtomEq)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), Quant(..))+import qualified Data.Logic.Classes.Formula as C+import Data.Logic.Classes.Literal (Literal(..))+import Data.Logic.Classes.Negate (Negatable(..)) import Data.Logic.Classes.Skolem (Skolem(..))-import Data.Logic.Classes.Term (Term(..), showTerm)-import Data.Logic.Classes.Variable (Variable)+import Data.Logic.Classes.Term (Term(..))+import Data.Logic.Classes.Variable (Variable(..)) import Data.Logic.Classes.Propositional (PropositionalFormula(..))-import Data.SafeCopy (base, deriveSafeCopy)+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.Typeable (Typeable) import Happstack.Data (deriveNewData)  -- | 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 (Combine (Formula v p f))+    | Combine (Combination (Formula v p f))     | Quant Quant v (Formula v p 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,Read,Data,Typeable)+    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+    = Equal term term+    | Apply p [term]+    deriving (Eq,Ord,Data,Typeable,Show,Read)+ -- | The range of a term is an element of a set. data PTerm v f     = Var v                         -- ^ A variable, either free or@@ -43,118 +56,153 @@                                     -- Constants are encoded as                                     -- nullary functions.  The result                                     -- is another term.-    deriving (Eq,Ord,Read,Data,Typeable)---- data InfixPred = (:=:) | (:!=:) deriving (Eq,Ord,Show,Data,Typeable,Enum,Bounded)---- |We need to implement read manually here due to--- <http://hackage.haskell.org/trac/ghc/ticket/4136>-{--instance Read InfixPred where-    readsPrec _ s =-        map (\ (x, t) -> (x, drop (length t) s))-            (take 1 (dropWhile (\ (_, t) -> not (isPrefixOf t s)) prs))-        where-          prs = [((:=:), ":=:"),-                 ((:!=:), ":!=:")]--}+    deriving (Eq,Ord,Data,Typeable,Show,Read) -instance (FirstOrderFormula (Formula v p f) (PTerm v f) v p f, Show v, Show p, Show f) => Show (Formula v p f) where-    show = showFirstOrder+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 -instance (FirstOrderFormula (Formula v p f) (PTerm v f) v p f, Show v, Show p, Show f) => Show (PTerm v f) where-    show = showTerm+instance Constants p => Constants (Formula v p f) where+    fromBool = Predicate . fromBool -instance Negatable (Formula v p f) where-    (.~.) (Combine ((:~:) (Combine ((:~:) x)))) = (.~.) x-    (.~.) (Combine ((:~:) x)) = x-    (.~.) x = Combine ((:~:) x)-    negated (Combine ((:~:) x)) = not (negated x)-    negated _ = False+instance Constants p => Constants (Predicate p (PTerm v f)) where+    fromBool x = Apply (fromBool x) [] -instance (Ord v, Ord p, Ord f) => Logic (Formula v p f) where+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 (Ord v, Variable v, Data v,-          Ord p, Boolean p, Arity p, Data p,-          Ord f, Skolem f, Data f,-          Boolean (Formula v p f), Logic (Formula v p f)) =>+instance (Ord v, Variable v, Data v, Show v,+          Ord p, Constants p, Arity p, Data p, Show p,+          Ord f, Skolem f, Data f, Show f,+          Constants (Formula v p f), Combinable (Formula v p f)) =>          PropositionalFormula (Formula v p f) (Formula v p f) where     atomic (Predicate (Equal t1 t2)) = t1 .=. t2-    atomic (Predicate (NotEqual t1 t2)) = t1 .!=. t2     atomic (Predicate (Apply p ts)) = pApp p ts     atomic _ = error "atomic method of PropositionalFormula for Parameterized: invalid argument"-    foldPropositional c a formula =-        case formula of-          Quant _ _ _ -> error "foldF0: quantifiers should not be present"-          Combine x -> c x-          Predicate x -> a (Predicate x)+    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 (Predicate x) -instance (Ord v, Variable v, Data v, Eq f, Ord f, Skolem f, Data f) => Term (PTerm v f) v f where+instance (Variable v, Data v, Skolem f, Data f, Ord f) => Term (PTerm v f) v f where     foldTerm vf fn t =         case t of           Var v -> vf v           FunApp f ts -> fn f ts-    zipT v f t1 t2 =+    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-    var = Var+    vt = Var     fApp x args = FunApp x args -instance (Ord v, Ord p, Boolean p, Arity p, Ord f) => Pred p (PTerm v f) (Formula v p f) where-    pApp0 x = Predicate (Apply x [])-    pApp1 x a = Predicate (Apply x [a])-    pApp2 x a b = Predicate (Apply x [a,b])-    pApp3 x a b c = Predicate (Apply x [a,b,c])-    pApp4 x a b c d = Predicate (Apply x [a,b,c,d])-    pApp5 x a b c d e = Predicate (Apply x [a,b,c,d,e])-    pApp6 x a b c d e f = Predicate (Apply x [a,b,c,d,e,f])-    pApp7 x a b c d e f g = Predicate (Apply x [a,b,c,d,e,f,g])-    x .=. y = Predicate (Equal x y)-    x .!=. y = Predicate (NotEqual x y)+{-+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 (Pred p (PTerm v f) (Formula v p f),+instance (Constants p, Eq p, Arity p, Show 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 (AtomEq (Predicate p (PTerm v f)) p (PTerm v f),+          Constants (Formula v p f),           Variable v, Ord v, Data v, Show v,-          Ord p, Data p, Show p,+          Ord p, Data p, Show p, Constants p,           Skolem f, Ord f, Data f, Show f) =>-         FirstOrderFormula (Formula v p f) (PTerm v f) v p f where-    for_all v x = Quant All v x+         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 q c p f =-        case f of-          Quant op v f' -> q op v f'-          Combine x -> c x-          Predicate x -> p x-    zipFirstOrder q c p f1 f2 =+    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') -> q q1 v1 (Quant q1 v1 f1') q2 v2 (Quant q2 v2 f2')-          (Combine x, Combine y) -> c x y-          (Predicate x, Predicate y) -> p x y+          (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+-}+    atomic = Predicate -instance (Variable v, Ord v, Data v, Show v,-          Arity p, Boolean p, Ord p, Data p, Show p,-          Skolem f, Ord f, Data f, Show f) => Literal (Formula v p f) (PTerm v f) v p f where-    equals x y = Predicate (Equal x y)-    pAppLiteral p ts = Predicate (Apply p ts)-    foldLiteral c pr l =+{-+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)) -> c x-          (Predicate (Apply p ts)) -> pr (ApplyLit p ts)-          (Predicate (Equal x y)) -> pr (EqualLit x y)-          _ -> error "Invalid formula used as Literal instance"-    zipLiterals c pr l1 l2 =-        case (l1, l2) of-          (Combine ((:~:) x), Combine ((:~:) y)) -> c x y-          (Predicate (Apply p1 ts1), Predicate (Apply p2 ts2)) -> pr (ApplyLit p1 ts1) (ApplyLit p2 ts2)-          _ -> Nothing+          (Combine ((:~:) x)) -> co x+          (Predicate p) -> at p+          _ -> error "Literal (Formula v p f)"+    atomic = Predicate+-} +instance (Constants p, Eq v, Eq p, Eq f, Constants (Predicate p (PTerm v f))) => Literal (Formula v p f) (Predicate p (PTerm v f)) v where+    atomic = Predicate+    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 (Arity p, Constants p, Variable v, Skolem f, Show p, Ord f, Data v, Data f, Eq p) => C.Formula (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+ $(deriveSafeCopy 1 'base ''PTerm) $(deriveSafeCopy 1 'base ''Formula)+$(deriveSafeCopy 2 'extension ''Predicate) -$(deriveNewData [''PTerm, ''Formula])+$(deriveNewData [''PTerm, ''Formula, ''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)++$(deriveSafeCopy 1 'base ''Predicate_v1)++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"
Data/Logic/Types/FirstOrderPublic.hs view
@@ -13,18 +13,15 @@  import Data.Data (Data) import Data.Logic.Classes.Arity (Arity)-import Data.Logic.Classes.Boolean (Boolean(..))+import Data.Logic.Classes.Combine (Combinable(..), Combination(..))+import Data.Logic.Classes.Constants (Constants(..)) import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..))-import qualified Data.Logic.Types.FirstOrder as N-import Data.Logic.Classes.Logic (Logic(..))-import Data.Logic.Classes.Negatable (Negatable(..))-import Data.Logic.Classes.Pred (Pred(..))-import Data.Logic.Classes.Propositional (Combine(..))+import Data.Logic.Classes.Negate (Negatable(..)) import Data.Logic.Classes.Skolem (Skolem(..))-import Data.Logic.Classes.Term (Term(..), )+import Data.Logic.Classes.Term (Term(..)) import Data.Logic.Classes.Variable (Variable)-import Data.Logic.Normal.Implicative (implicativeNormalForm, ImplicativeForm)-import Data.Logic.Normal.Skolem (runNormal)+import Data.Logic.Normal.Implicative (implicativeNormalForm, ImplicativeForm, runNormal)+import qualified Data.Logic.Types.FirstOrder as N import Data.SafeCopy (base, deriveSafeCopy) import Data.Set (Set) import Data.Typeable (Typeable)@@ -38,70 +35,68 @@ -- |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 (Read, Data, Typeable)+data Formula v p f = Formula {unFormula :: N.Formula v p f} deriving (Data, Typeable)  instance Bijection (Formula v p f) (N.Formula v p f) where     public = Formula     intern = unFormula -instance Bijection (Combine (Formula v p f)) (Combine (N.Formula v p f)) where+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 Negatable (Formula v p f) where-    negated = negated . unFormula-    (.~.) = Formula . (.~.) . unFormula+    negatePrivate = Formula . negatePrivate . unFormula+    foldNegation normal inverted = foldNegation (normal . Formula) (inverted . Formula) . unFormula -instance (Variable v, Show v, Ord v, Data v,-          Arity p, Boolean p, Show p, Ord p, Data p,-          Skolem f, Show f, Ord f, Data f) => Logic (Formula v p f) where+instance (Constants (N.Formula v p f), Arity p, Constants p, Ord v, Ord p, Ord f, Variable v, Skolem f, Show v, Show p, Show f, Data v, Data f, Data p) => Constants (Formula v p f) where+    fromBool = Formula . fromBool++instance (Constants (Formula v p f), Constants (N.Formula v p f),+          Variable v, Show v, Ord v, Data v,+          Arity p, Constants p, Show p, Ord p, Data p,+          Skolem f, Show f, Ord f, Data f) => 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 (Arity p, Variable v, Skolem f, Boolean p,+instance (Constants (N.Formula v p f),+          Arity p, Variable v, Skolem f, Constants p,           Show p, Show v, Show f,           Ord f, Ord v, Ord p,           Data p, Data v, Data f) => Show (Formula v p f) where     showsPrec n x = showsPrec n (unFormula x) -instance (Variable v, Show v, Ord v, Data v,-          Show p, Ord p, Data p, Boolean p, Arity p,-          Skolem f, Show f, Ord f, Data f) => Pred p (N.PTerm v f) (Formula v p f) where-    pApp0 p = (public :: N.Formula v p f -> Formula v p f) $ pApp0 p-    pApp1 p t1 = (public :: N.Formula v p f -> Formula v p f) $ pApp1 p (t1)-    pApp2 p t1 t2 = (public :: N.Formula v p f -> Formula v p f) $ pApp2 p (t1) (t2)-    pApp3 p t1 t2 t3 = (public :: N.Formula v p f -> Formula v p f) $ pApp3 (p) (t1) (t2) (t3)-    pApp4 p t1 t2 t3 t4 = (public :: N.Formula v p f -> Formula v p f) $ pApp4 (p) (t1) (t2) (t3) (t4)-    pApp5 p t1 t2 t3 t4 t5 = (public :: N.Formula v p f -> Formula v p f) $ pApp5 (p) (t1) (t2) (t3) (t4) (t5)-    pApp6 p t1 t2 t3 t4 t5 t6 = (public :: N.Formula v p f -> Formula v p f) $ pApp6 (p) (t1) (t2) (t3) (t4) (t5) (t6)-    pApp7 p t1 t2 t3 t4 t5 t6 t7 = (public :: N.Formula v p f -> Formula v p f) $ pApp7 (p) (t1) (t2) (t3) (t4) (t5) (t6) (t7)-    t1 .=. t2 = (public :: N.Formula v p f -> Formula v p f) $ (t1) .=. (t2)--instance (Logic (Formula v p f), Term (N.PTerm v f) v f,+instance (Constants (Formula v p f), Constants (N.Formula v p f),+          Combinable (Formula v p f), Term (N.PTerm v f) v f,           Show v,-          Arity p, Boolean p, Ord p, Data p, Show p,-          Ord f, Show f) => FirstOrderFormula (Formula v p f) (N.PTerm v f) v p f where+          Arity p, Constants p, Ord p, Data p, Show p,+          Ord f, Show f) => 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 q c p f = foldFirstOrder q' c' p (intern f :: N.Formula v p f)-        where q' quant v form = q quant v (public form)-              c' x = c (public x)+    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)+{-     zipFirstOrder q c p f1 f2 = zipFirstOrder q' c' p (intern f1 :: N.Formula v p f) (intern f2 :: N.Formula v p f)         where q' q1 v1 f1' q2 v2 f2' = q q1 v1 (public f1') q2 v2 (public f2')               c' combine1 combine2 = c (public combine1) (public combine2)+-}+    atomic = Formula . atomic  -- |Here are the magic Ord and Eq instances instance ({- FirstOrderFormula (Formula v p f) (N.PTerm v f) v p f,           Literal (N.Formula v p f) (N.PTerm v f) v p f,           FirstOrderFormula (N.Formula v p f) (N.PTerm v f) v p f, -}+          Constants (N.Predicate p (N.PTerm v f)),+          Constants (Formula v p f), Constants (N.Formula v p f),           Data v, Data f, Data p,           Ord v, Ord p, Ord f,           Show v, Show p, Show f,-          Arity p, Boolean p, Skolem f, Variable v,+          Arity p, Constants p, Skolem f, Variable v,           Ord (N.Formula v p f)) => Ord (Formula v p f) where     compare a b =         let (a' :: Set (ImplicativeForm (N.Formula v p f))) = runNormal (implicativeNormalForm (intern a :: N.Formula v p f))@@ -110,7 +105,8 @@           EQ -> EQ           x -> {- if isRenameOf a' b' then EQ else -} x -instance (FirstOrderFormula (Formula v p f) (N.PTerm v f) v p f) => Eq (Formula v p f) where+instance (Arity p, Constants p, Skolem f, Show p, Show f, Ord p, Ord f, Data f, Data v, Data p, 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     a == b = compare a b == EQ  $(deriveSafeCopy 1 'base ''Formula)
+ Data/Logic/Types/Harrison/Equal.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeSynonymInstances #-}+{-# 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.Logic.Classes.Arity (Arity(..))+import Data.Logic.Classes.Apply (Apply(..))+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 (FirstOrderFormula(..))+import qualified Data.Logic.Classes.FirstOrder as C+import qualified Data.Logic.Classes.Formula as C+import Data.Logic.Classes.Literal (Literal(..))+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(..))++data FOLEQ = EQUALS TermType TermType | R String [TermType] deriving (Eq, Ord, Show)+data PredName = (:=:) | Named String deriving (Eq, Ord, Show)++instance Arity PredName where+    arity (:=:) = Just 2+    arity _ = Nothing++instance Show (Formula FOLEQ) where+    show = showFirstOrderFormulaEq++instance IsString PredName where+    fromString "=" = (:=:)+    fromString s = Named s++instance Constants PredName where+    fromBool True = Named "true"+    fromBool False = Named "false"++instance Constants FOLEQ where+    fromBool x = R (fromBool x) []++-- | 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 Literal (Formula FOLEQ) FOLEQ String where+    atomic = Atom+    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.Formula 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 view
@@ -0,0 +1,108 @@+{-# 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.Logic.Classes.Arity+import Data.Logic.Classes.Apply (Apply(..), showApply)+import Data.Logic.Classes.Combine (Combination(..), BinOp(..))+import Data.Logic.Classes.Constants (Constants(fromBool), asBool)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), showFirstOrder)+import Data.Logic.Classes.Skolem (Skolem(..))+import Data.Logic.Classes.Term (Term(vt, foldTerm, fApp))+import Data.Logic.Classes.Variable (Variable(..))+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.Harrison.Formulas.FirstOrder as H+import qualified Data.Set as Set+import Prelude hiding (pred)+import Text.PrettyPrint (text)++-- -------------------------------------------------------------------------+-- 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) = "var " ++ show v+    show (Fn f ts) = "fApp " ++ show f ++ " " ++ show ts++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"++instance Constants FOL where+    fromBool x = R (fromBool x) []++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 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 Int+    deriving (Eq, Ord, Data, Typeable, Show)++instance Skolem Function where+    toSkolem = Skolem+    fromSkolem (Skolem n) = Just n+    fromSkolem _ = Nothing++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 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 Show (Formula FOL) where+    show = showFirstOrder showApply
+ Data/Logic/Types/Harrison/Formulas/FirstOrder.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, DeriveDataTypeable, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -Wwarn #-}+module Data.Logic.Types.Harrison.Formulas.FirstOrder+    ( Formula(..)+    ) where++import Data.Logic.Classes.Combine (Combinable(..))+import Data.Logic.Classes.Constants (Constants(..))+import Data.Logic.Classes.Negate (Negatable(..))++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++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
+ Data/Logic/Types/Harrison/Formulas/Propositional.hs view
@@ -0,0 +1,52 @@+{-# 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 Data.Logic.Classes.Negate (Negatable(..))+import Data.Logic.Classes.Propositional (PropositionalFormula(..))++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++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 Combinable (Formula atom) => PropositionalFormula (Formula atom) atom where+    -- The atom type for this formula is the same as its first type parameter.+    atomic = Atom+    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
+ Data/Logic/Types/Harrison/Prop.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies #-}+{-# OPTIONS_GHC -Wall -Wwarn #-}+module Data.Logic.Types.Harrison.Prop+    ( Prop(..)+    ) where++import Data.Generics (Data, Typeable)+import Data.Logic.Classes.Propositional+import Data.Logic.Types.Harrison.Formulas.Propositional (Formula(..))+import Prelude hiding (negate)++-- =========================================================================+-- 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 Show (Formula Prop) where+    show = showPropositional show++instance Show (Formula String) where+    show = showPropositional show
Data/Logic/Types/Propositional.hs view
@@ -2,47 +2,36 @@ module Data.Logic.Types.Propositional where  import Data.Generics (Data, Typeable)-import Data.Logic.Classes.Negatable (Negatable(..))-import Data.Logic.Classes.Propositional (PropositionalFormula(..), Combine(..), BinOp(..))-import Data.Logic.Classes.Logic (Logic(..))-import Data.Logic.Classes.Boolean (Boolean(..))+import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..))+import Data.Logic.Classes.Constants (Constants(..), asBool)+import Data.Logic.Classes.Negate (Negatable(..))+import Data.Logic.Classes.Propositional (PropositionalFormula(..))  -- | The range of a formula is {True, False} when it has no free variables. data Formula atom-    = Combine (Combine (Formula atom))+    = Combine (Combination (Formula atom))     | Atom atom     -- 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,Read,Data,Typeable)+    deriving (Eq,Ord,Data,Typeable)  instance Negatable (Formula atom) where-    (.~.) (Combine ((:~:) (Combine ((:~:) x)))) = (.~.) x-    (.~.) (Combine ((:~:) x)) = x-    (.~.) x = Combine ((:~:) x)-    negated (Combine ((:~:) x)) = not (negated x)-    negated _ = False+    negatePrivate x = Combine ((:~:) x)+    foldNegation normal inverted (Combine ((:~:) x)) = foldNegation inverted normal x+    foldNegation normal _ x = normal x -instance Ord atom => Logic (Formula atom) where+instance (Constants atom, 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 Boolean atom => Boolean (Formula atom) where+instance Constants atom => Constants (Formula atom) where     fromBool = Atom . fromBool -instance (Boolean atom, Ord atom) => PropositionalFormula (Formula atom) atom where+instance (Constants atom, Ord atom) => PropositionalFormula (Formula atom) atom where     atomic a = Atom a-    foldPropositional c a formula =+    foldPropositional co tf at formula =         case formula of-          Combine x -> c x-          Atom x -> a x-{--    asBool (Atom x) =-        if x == fromBool True-        then Just True-        else if x == fromBool False-             then Just False-             else Nothing-    asBool (Combine _) = Nothing--}+          Combine x -> co x+          Atom x -> maybe (at x) tf (asBool x)
Setup.hs view
@@ -7,7 +7,6 @@ import Distribution.Simple.Program import System.Cmd import System.Exit-import System.Posix.Files (fileExist)  main :: IO () main = defaultMainWithHooks simpleUserHooks {
− Test/Chiou0.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE OverloadedStrings, StandaloneDeriving #-}-{-# OPTIONS -fno-warn-orphans #-}--module Test.Chiou0 where--import Control.Monad.Identity (runIdentity)-import Control.Monad.Trans (MonadIO, liftIO)-import Data.Logic.Classes.Boolean (Boolean(..))-import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..))-import Data.Logic.Classes.Logic (Logic(..))-import Data.Logic.Classes.Negatable (Negatable(..))-import Data.Logic.Classes.Pred (pApp)-import Data.Logic.Classes.Skolem (Skolem(..))-import Data.Logic.Classes.Term (Term(..))-import Data.Logic.KnowledgeBase (ProverT, runProver', Proof(..), ProofResult(..), loadKB, theoremKB {-, askKB, showKB-})-import Data.Logic.Normal.Clause (clauseNormalForm)-import Data.Logic.Normal.Implicative (ImplicativeForm(INF), makeINF')-import Data.Logic.Normal.Skolem (NormalT, runNormal)-import Data.Logic.Resolution (SetOfSupport)-import Data.Logic.Test (V(..), Pr(..), AtomicFunction(..), TFormula, TTerm)-import Data.Logic.Types.FirstOrder (Formula, PTerm)-import Data.Map (fromList)-import qualified Data.Set as S-import Data.String (IsString(..))-import Test.HUnit--tests :: Test-tests = TestLabel "Chiou0" $ TestList [loadTest, proofTest1, proofTest2]--loadTest :: Test-loadTest =-    TestCase (assertEqual "Chiuo0 - loadKB test" expected (runProver' Nothing (loadKB sentences)))-    where-      expected :: [Proof TFormula]-      expected = [Proof Invalid (S.fromList [makeINF' ([]) ([(pApp ("Dog") [fApp (toSkolem 1) []])]),-                                             makeINF' ([]) ([(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem 1) []])])]),-                  Proof Invalid (S.fromList [makeINF' ([(pApp ("Dog") [var ("y2")]),(pApp ("Owns") [var ("x"),var ("y")])]) ([(pApp ("AnimalLover") [var ("x")])])]),-                  Proof Invalid (S.fromList [makeINF' ([(pApp ("Animal") [var ("y")]),(pApp ("AnimalLover") [var ("x")]),(pApp ("Kills") [var ("x"),var ("y")])]) ([])]),-                  Proof Invalid (S.fromList [makeINF' ([]) ([(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []]),(pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])])]),-                  Proof Invalid (S.fromList [makeINF' ([]) ([(pApp ("Cat") [fApp ("Tuna") []])])]),-                  Proof Invalid (S.fromList [makeINF' ([(pApp ("Cat") [var ("x")])]) ([(pApp ("Animal") [var ("x")])])])]--proofTest1 :: Test-proofTest1 = TestCase (assertEqual "Chiuo0 - proof test 1" proof1 (runProver' Nothing (loadKB sentences >> theoremKB (pApp "Kills" [fApp "Jack" [], fApp "Tuna" []] :: TFormula))))--inf' l1 l2 = INF (S.fromList l1) (S.fromList l2)--proof1 :: (Bool, SetOfSupport TFormula V TTerm)-proof1 = (False,-          (S.fromList-           [(makeINF' ([(pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])]) ([]),fromList []),-            (makeINF' ([]) ([(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []])]),fromList []),-            (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("AnimalLover") [fApp ("Curiosity") []])]) ([]),fromList []),-            (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Dog") [var ("y2")]),(pApp ("Owns") [fApp ("Curiosity") [],var ("y")])]) ([]),fromList []),-            (makeINF' ([(pApp ("AnimalLover") [fApp ("Curiosity") []]),(pApp ("Cat") [fApp ("Tuna") []])]) ([]),fromList []),-            (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Curiosity") [],var ("y")])]) ([]),fromList []),-            (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Dog") [var ("y2")]),(pApp ("Owns") [fApp ("Curiosity") [],var ("y")])]) ([]),fromList []),-            (makeINF' ([(pApp ("AnimalLover") [fApp ("Curiosity") []])]) ([]),fromList []),-            (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Curiosity") [],var ("y")])]) ([]),fromList []),-            (makeINF' ([(pApp ("Dog") [var ("y2")]),(pApp ("Owns") [fApp ("Curiosity") [],var ("y")])]) ([]),fromList []),-            (makeINF' ([(pApp ("Owns") [fApp ("Curiosity") [],var ("y")])]) ([]),fromList [])]))--proofTest2 :: Test-proofTest2 = TestCase (assertEqual "Chiuo0 - proof test 2" proof2 (runProver' Nothing (loadKB sentences >> theoremKB conjecture)))-    where-      conjecture :: TFormula-      conjecture = (pApp "Kills" [fApp "Curiosity" [], fApp (Fn "Tuna") []])--proof2 :: (Bool, SetOfSupport TFormula V TTerm)-proof2 = (True,-          S.fromList-          [(makeINF' ([]) ([]),fromList []),-           (makeINF' ([]) ([(pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])]),fromList []),-           (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []])]) ([]),fromList []),-           (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("AnimalLover") [fApp ("Jack") []])]) ([]),fromList []),-           (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Dog") [var ("y2")])]) ([]),fromList []),-           (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Dog") [var ("y2")]),(pApp ("Owns") [fApp ("Jack") [],var ("y")])]) ([]),fromList []),-           (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Jack") [],var ("y")])]) ([]),fromList []),-           (makeINF' ([(pApp ("AnimalLover") [fApp ("Jack") []])]) ([]),fromList []),-           (makeINF' ([(pApp ("AnimalLover") [fApp ("Jack") []]),(pApp ("Cat") [fApp ("Tuna") []])]) ([]),fromList []),-           (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []])]) ([]),fromList []),-           (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Dog") [var ("y2")])]) ([]),fromList []),-           (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Dog") [var ("y2")]),(pApp ("Owns") [fApp ("Jack") [],var ("y")])]) ([]),fromList []),-           (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Jack") [],var ("y")])]) ([]),fromList []),-           (makeINF' ([(pApp ("Dog") [var ("y2")]),(pApp ("Owns") [fApp ("Jack") [],var ("y")])]) ([]),fromList []),-           (makeINF' ([(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []])]) ([]),fromList [])])--testProof :: MonadIO m => String -> (TFormula, Bool, (S.Set (ImplicativeForm TFormula))) -> ProverT (ImplicativeForm TFormula) (NormalT V TTerm m) ()-testProof label (question, expectedAnswer, expectedProof) =-    theoremKB question >>= \ (actualFlag, actualProof) ->-    let actual' = (actualFlag, S.map fst actualProof) in-    if actual' /= (expectedAnswer, expectedProof)-    then error ("\n Expected:\n  " ++ show (expectedAnswer, expectedProof) ++-                "\n Actual:\n  " ++ show actual')-    else liftIO (putStrLn (label ++ " ok"))--loadCmd :: Monad m => ProverT (ImplicativeForm TFormula) (NormalT V TTerm m) [Proof TFormula]-loadCmd = loadKB sentences--sentences :: [TFormula]-sentences = [exists "x" ((pApp "Dog" [var "x"]) .&. (pApp "Owns" [fApp "Jack" [], var "x"])),-             for_all "x" (((exists "y" (pApp "Dog" [var "y"])) .&. (pApp "Owns" [var "x", var "y"])) .=>. (pApp "AnimalLover" [var "x"])),-             for_all "x" ((pApp "AnimalLover" [var "x"]) .=>. (for_all "y" ((pApp "Animal" [var "y"]) .=>. ((.~.) (pApp "Kills" [var "x", var "y"]))))),-             (pApp "Kills" [fApp "Jack" [], fApp "Tuna" []]) .|. (pApp "Kills" [fApp "Curiosity" [], fApp "Tuna" []]),-             pApp "Cat" [fApp "Tuna" []],-             for_all "x" ((pApp "Cat" [var "x"]) .=>. (pApp "Animal" [var "x"]))]
− Test/Data.hs 
@@ -1,1077 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, MonoLocalBinds, NoMonomorphismRestriction, OverloadedStrings, RankNTypes, ScopedTypeVariables  #-}-{-# OPTIONS -fno-warn-name-shadowing -fno-warn-missing-signatures #-}-module Test.Data-    ( tests-    , allFormulas-    , proofs-{--    , formulas-    , animalKB-    , animalConjectures-    , chang43KB-    , chang43Conjecture-    , chang43ConjectureRenamed--}-    ) where--import Data.Boolean.SatSolver (Literal(..))-import Data.Generics (Typeable)-import Data.Logic.Classes.Boolean (Boolean(..))-import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), for_all', exists', convertFOF)-import Data.Logic.Classes.Logic (Logic(..))-import Data.Logic.Classes.Term (Term(..))-import Data.Logic.Classes.Skolem (Skolem(toSkolem))-import Data.Logic.Classes.Pred (Pred(..), pApp)-import Data.Logic.Classes.Negatable (Negatable(..))-import qualified Data.Logic.Classes.Literal as N-import qualified Data.Logic.Instances.Chiou as C-import Data.Logic.KnowledgeBase (WithId(WithId, wiItem, wiIdent), Proof(..), ProofResult(..))-import Data.Logic.Normal.Implicative (ImplicativeForm(INF), makeINF')-import Data.Logic.Test (TestFormula(..), TestProof(..), Expected(..), ProofExpected(..), doTest, doProof)-import Data.Map (fromList)-import qualified Data.Set as S-import Data.String (IsString)-import Test.HUnit--tests :: (FirstOrderFormula formula term v p f, N.Literal formula term v p f, Eq term, Show term, Show formula, Show v) =>-         [TestFormula formula term v p f] -> [TestProof formula term v] -> Test-tests fs ps =-    TestLabel "New" $ TestList (map doTest fs ++ map doProof ps)--allFormulas :: forall formula term v p f. (FirstOrderFormula formula term v p f, Ord formula, Typeable formula, IsString v, IsString p, IsString f) =>-               [TestFormula formula term v p f]-allFormulas = (formulas ++-               concatMap snd [animalKB, chang43KB] ++-               animalConjectures ++-               [chang43Conjecture, chang43ConjectureRenamed])--formulas :: forall formula term v p f. (FirstOrderFormula formula term v p f, Ord formula, IsString v, IsString p, IsString f) =>-            [TestFormula formula term v p f]-formulas =-    let n = (.~.) :: Logic formula => formula -> formula-        p = pApp "p" :: [term] -> formula-        q = pApp "q" :: [term] -> formula-        r = pApp "r" :: [term] -> formula-        s = pApp "s" :: [term] -> formula-        t = pApp "t" :: [term] -> formula-        p0 = p [] :: formula-        q0 = q [] :: formula-        r0 = r [] :: formula-        s0 = s [] :: formula-        t0 = t [] :: formula-        (x, y, z, u, v, w) :: (term, term, term, term, term, term) =-                              (var "x", var "y", var "z", var "u", var "v", var "w") in-    [ -      TestFormula-      { formula = p0 .|. q0 .&. r0 .|. n s0 .&. n t0-      , name = "operator precedence"-      , expected = [ FirstOrderFormula ((p0 .|. q0) .&. (r0 .|. (n s0)) .&. (n t0)) ] }-    , TestFormula-      { formula = pApp (fromBool True) []-      , name = "True"-      , expected = [ClauseNormalForm  (toSS [[]])] }-    , TestFormula-      { formula = pApp (fromBool False) []-      , name = "False"-      , expected = [ClauseNormalForm  (toSS [])] }-    , TestFormula-      { formula = pApp "p" []-      , name = "p"-      , expected = [ClauseNormalForm  (toSS [[pApp "p" []]])] }-    , let p = pApp "p" [] in-      TestFormula-      { formula = p .&. ((.~.) (p))-      , name = "p&~p"-      , expected = [ PrenexNormalForm ((pApp ("p") []) .&. (((.~.) (pApp ("p") []))))-                   , ClauseNormalForm (toSS [[(p)], [((.~.) (p))]])-                   ] }-    , TestFormula-      { formula = pApp "p" [var "x"]-      , name = "p[x]"-      , expected = [ClauseNormalForm  (toSS [[pApp "p" [x]]])] }-    , let f = pApp "f"-          q = pApp "q" in-      TestFormula-      { name = "iff"-      , formula = for_all "x" (for_all "y" (q [x, y] .<=>. for_all "z" (f [z, x] .<=>. f [z, y])))-      , expected = [ PrenexNormalForm -                     (for_all "x"-                      (for_all "y"-                       (for_all "z"-                        (exists "z2"-                         ((q [x,y] .&.-                           ((f [z,x] .&. f [z,y]) .|.-                            ((((.~.) (f [z,x])) .&. ((.~.) (f [z,y])))))) .|. ((((.~.) (q [x,y])) .&.-                            ((((f [var ("z2"),x] .&. (((.~.) (f [var ("z2"),y])))) .|.-                               (((.~.) (f [var ("z2"),x])))) .&. f [var ("z2"),y])))))-                        ))))-                   , ClauseNormalForm ----                    [[((.~.) (q [var "x",var "y"])),---                      ((.~.) (f [var "z",var "x"])),---                      (f [var "z",var "y"])],---                     [((.~.) (q [var "x",var "y"])),---                      ((.~.) (f [var "z",var "y"])),---                      (f [var "z",var "x"])],---                     [(f [fApp (toSkolem 1) [var "x",var "y",var "z"],var "x"]),---                      (f [fApp (toSkolem 1) [var "x",var "y",var "z"],var "y"]),---                      (q [var "x",var "y"])],---                     [((.~.) (f [fApp (toSkolem 1) [var "x",var "y",var "z"],var "y"])),---                      (f [fApp (toSkolem 1) [var "x",var "y",var "z"],var "y"]),---                      (q [var "x",var "y"])],---                     [(f [fApp (toSkolem 1) [var "x",var "y",var "z"],var "x"]),---                      ((.~.) (f [fApp (toSkolem 1) [var "x",var "y",var "z"],var "x"])),---                      (q [var "x",var "y"])],---                     [((.~.) (f [fApp (toSkolem 1) [var "x",var "y",var "z"],var "y"])),---                      ((.~.) (f [fApp (toSkolem 1) [var "x",var "y",var "z"],var "x"])),---                      (q [var "x",var "y"])]]]--                     (toSS [[(f [var ("z"),var ("x")]),-                             (f [fApp (toSkolem 1) [var ("x"),var ("y")],var ("y")]),-                             ((.~.) (f [var ("z"),var ("y")]))],-                            [(f [var ("z"),var ("x")]),-                             ((.~.) (f [var ("z"),var ("y")])),-                             ((.~.) (f [fApp (toSkolem 1) [var ("x"),var ("y")],var ("x")])),-                             ((.~.) (f [fApp (toSkolem 1) [var ("x"),var ("y")],var ("y")]))],-                            [(f [var ("z"),var ("x")]),-                             ((.~.) (f [var ("z"),var ("y")])),-                             ((.~.) (q [var ("x"),var ("y")]))],-                            [(f [var ("z"),var ("y")]),-                             (f [fApp (toSkolem 1) [var ("x"),var ("y")],var ("y")]),-                             ((.~.) (f [var ("z"),var ("x")]))],-                            [(f [var ("z"),var ("y")]),-                             ((.~.) (f [var ("z"),var ("x")])),-                             ((.~.) (f [fApp (toSkolem 1) [var ("x"),var ("y")],var ("x")])),-                             ((.~.) (f [fApp (toSkolem 1) [var ("x"),var ("y")],var ("y")]))],-                            [(f [var ("z"),var ("y")]),-                             ((.~.) (f [var ("z"),var ("x")])),-                             ((.~.) (q [var ("x"),var ("y")]))],-                            [(f [fApp (toSkolem 1) [var ("x"),var ("y")],var ("y")]),-                             (q [var ("x"),var ("y")])],-                            [(q [var ("x"),var ("y")]),-                             ((.~.) (f [fApp (toSkolem 1) [var ("x"),var ("y")],var ("x")])),-                             ((.~.) (f [fApp (toSkolem 1) [var ("x"),var ("y")],var ("y")]))]])-                   ]-      }-    , TestFormula-      { name = "move quantifiers out"-      , formula = (for_all "x" (pApp "p" [x]) .&. (pApp "q" [x]))-      , expected = [PrenexNormalForm (for_all "x2" ((pApp "p" [var ("x2")]) .&. ((pApp "q" [var ("x")]))))]-      }-    , TestFormula-      { name = "skolemize2"-      , formula = exists "x" (for_all "y" (pApp "loves" [x, y]))-      , expected = [SkolemNormalForm (pApp ("loves") [fApp (toSkolem 1) [],y])]-      }-    , TestFormula-      { name = "skolemize3"-      , formula = for_all "y" (exists "x" (pApp "loves" [x, y]))-      , expected = [SkolemNormalForm (pApp ("loves") [fApp (toSkolem 1) [y],y])]-      }-    , TestFormula-      { formula = exists "x" (for_all' ["y", "z"]-                              (exists "u"-                               (for_all "v"-                                (exists "w"-                                 (pApp "P" [x, y, z, u, v, w])))))-      , name = "chang example 4.1"-      , expected = [ SkolemNormalForm (pApp "P" [fApp (toSkolem 1) [],-                                                 var ("y"),-                                                 var ("z"),-                                                 fApp (toSkolem 2) [var ("y"),var ("z")],-                                                 var ("v"),-                                                 fApp (toSkolem 3) [var ("v"), var ("y"),var ("z")]]) ]-      }-    , TestFormula-      { name = "chang example 4.2"-      -- ∀x ∃y∃z ~P(x,y) & Q(x,z) | R(x,y,z)-      , formula = for_all "x" (exists' ["y", "z"] (((((.~.) (pApp "P" [x, y])) .&. pApp "Q" [x, z]) .|. pApp "R" [x, y, z])))-      -- ∀x ~P(x,Sk1[x]) | R(x,Sk1[x],Sk2[x]) & Q(x,Sk2[x]) | R(x,Sk1[x],Sk2[x])-      , expected = [ SkolemNormalForm-                     ((((.~.) (pApp ("P") [var ("x"),var ("y")])) .&.-                       ((pApp ("Q") [var ("x"),var ("z")]))) .|.-                      ((pApp ("R") [var ("x"),var ("y"),var ("z")])))-                   , ClauseNormalForm-                     (toSS -                      [[((.~.) (pApp ("P") [var ("x"),var ("y")])),-                       (pApp ("R") [var ("x"),var ("y"),var ("z")])],-                      [(pApp ("Q") [var ("x"),var ("z")]),-                       (pApp ("R") [var ("x"),var ("y"),var ("z")])]]) ]-      }-    , TestFormula-      { formula = n p0 .|. q0 .&. p0 .|. r0 .&. n q0 .&. n r0-      , name = "chang 7.2.1a - unsat"-      , expected = [ SatSolverSat False ] }-    , TestFormula-      { formula = p0 .|. q0 .|. r0 .&. n p0 .&. n q0 .&. n r0 .|. s0 .&. n s0-      , name = "chang 7.2.1b - unsat"-      , expected = [ SatSolverSat False ] }-    , TestFormula-      { formula = p0 .|. q0 .&. q0 .|. r0 .&. r0 .|. s0 .&. n r0 .|. n p0 .&. n s0 .|. n q0 .&. n q0 .|. n r0-      , name = "chang 7.2.1c - unsat"-      , expected = [ SatSolverSat False ] }-    , let q = pApp "q"-          f = pApp "f"-          sk1 = f [fApp (toSkolem 1) [x,x,y,z],y]-          sk2 = f [fApp (toSkolem 1) [x,x,y,z],x]-          (x, y, z) = (var "x", var "y", var "z") in-      TestFormula-      { name = "distribute bug test"-      , formula = ((((.~.) (q [x,y])) .|.-                    ((((.~.) (sk2)) .|. (sk1)) .&.-                     (((.~.) (sk1)) .|. (sk2)))) .&.-                   ((((sk2) .&.-                      ((.~.) (sk1))) .|. ((sk1) .&.-                      ((.~.) (sk2)))) .|. (q [x,y])))-      , expected = [ClauseNormalForm-                    (toSS-                     [[sk2,sk1,pApp ("q") [x,y]],-                      [sk2,((.~.) (sk1)),((.~.) (q [x,y]))],-                      [sk1,((.~.) (sk2)),((.~.) (q [x,y]))],-                      [q [x,y], ((.~.) sk2),((.~.) sk1)]])]-      }-    , let (x, y) = (var "x", var "y")-          (x', y') = (var "x", var "y") in-      TestFormula-      { name = "convert to Chiou 1"-      , formula = exists "x" (x .=. y)-      , expected = [ConvertToChiou (exists "x" (x' .=. y'))]-      }-    , let s = pApp "s"-          s' = pApp "s"-          x' = var "x"-          y' = var "y" in-      TestFormula-      { name = "convert to Chiou 2"-      , formula = s [fApp ("a") [x, y]]-      , expected = [ConvertToChiou (s' [fApp "a" [x', y']])]-      }-    , let s :: [term] -> formula-          s = pApp "s"-          h :: [term] -> formula-          h = pApp "h"-          m :: [term] -> formula-          m = pApp "m"-          s' :: [term] -> formula-          s' = pApp "s"-          h' :: [term] -> formula-          h' = pApp "h"-          m' :: [term] -> formula-          m' = pApp "m"-          x' :: term-          x' = var "x" in-      TestFormula-      { name = "convert to Chiou 3"-      , formula = for_all "x" (((s [x] .=>. h [x]) .&. (h [x] .=>. m [x])) .=>. (s [x] .=>. m [x]))-      , expected = [ConvertToChiou (for_all "x" (((s' [x'] .=>. h' [x']) .&. (h' [x'] .=>. m' [x'])) .=>. (s' [x'] .=>. m' [x'])))]-      }-    , let taller :: term -> term -> formula-          taller a b = pApp ("taller" :: p) [a, b]-          wise :: term -> formula-          wise a = pApp ("wise" :: p) [a] in-      TestFormula-      { name = "cnf test 1"-      , formula = for_all "y" (for_all "x" (taller y x .|. wise x) .=>. wise y)-      , expected = [ClauseNormalForm-                    (toSS-                     [[(pApp ("wise") [var ("y")]),-                       ((.~.) (pApp ("taller") [var ("y"),fApp (toSkolem 1) [var ("y")]]))],-                      [(pApp ("wise") [var ("y")]),-                       ((.~.) (pApp ("wise") [fApp (toSkolem 1) [var ("y")]]))]])]-      }-    , TestFormula-      { name = "cnf test 2"-      , formula = ((.~.) (exists "x" (pApp "s" [x] .&. pApp "q" [x])))-      , expected = [ ClauseNormalForm (toSS -                                       [[((.~.) (pApp ("q") [var ("x")])),-                                         ((.~.) (pApp ("s") [var ("x")]))]])-                   , PrenexNormalForm (for_all "x"-                                       (((.~.) (pApp ("s") [var ("x")])) .|.-                                        (((.~.) (pApp ("q") [var ("x")])))))-                                     {- [[((.~.) (pApp "s" [var "x"])),-                                        ((.~.) (pApp "q" [var "x"]))]] -}-                   ]-      }-    , TestFormula-      { name = "cnf test 3"-      , formula = (for_all "x" (p [x] .=>. (q [x] .|. r [x])))-      , expected = [ClauseNormalForm (toSS [[((.~.) (pApp "p" [var "x"])),(pApp "q" [var "x"]),(pApp "r" [var "x"])]])]-      }-    , TestFormula-      { name = "cnf test 4"-      , formula = ((.~.) (exists "x" (p [x] .=>. exists "y" (q [y]))))-      , expected = [ClauseNormalForm (toSS [[(pApp "p" [var "x"])],[((.~.) (pApp "q" [var "y"]))]])]-      }-    , TestFormula-      { name = "cnf test 5"-      , formula = (for_all "x" (q [x] .|. r [x] .=>. s [x]))-      , expected = [ClauseNormalForm (toSS [[((.~.) (pApp "q" [var "x"])),(pApp "s" [var "x"])],[((.~.) (pApp "r" [var "x"])),(pApp "s" [var "x"])]])]-      }-    , TestFormula-      { name = "cnf test 6"-      , formula = (exists "x" (p0 .=>. pApp "f" [x]))-      , expected = [ClauseNormalForm (toSS [[((.~.) (pApp "p" [])),(pApp "f" [fApp (toSkolem 1) []])]])]-      }-    , let p = pApp "p" []-          f' = pApp "f" [x]-          f = pApp "f" [fApp (toSkolem 1) []] in-      TestFormula-      { name = "cnf test 7"-      , formula = exists "x" (p .<=>. f')-      , expected = [ PrenexNormalForm (exists "x" ((p .&. f') .|. ((((.~.) p) .&. (((.~.) f'))))))-                   , SkolemNormalForm ((p .&. f) .|. (((.~.) p) .&. (((.~.) f))))-                   , TrivialClauses [(False,S.fromList [((.~.) (pApp ("p") [])),(pApp ("f") [fApp (toSkolem 1) []])]),-                                     (False,S.fromList [((.~.) (pApp ("f") [fApp (toSkolem 1) []])),(pApp ("p") [])])]-                   , ClauseNormalForm (toSS [[(f), ((.~.) p)], [p, ((.~.) f)]])]-      }-    , TestFormula-      { name = "cnf test 8"-      , formula = (for_all "z" (exists "y" (for_all "x" (pApp "f" [x, y] .<=>. (pApp "f" [x, z] .&. ((.~.) (pApp "f" [x, x])))))))-      , expected = [ClauseNormalForm -                    (toSS [[((.~.) (pApp "f" [var "x",fApp (toSkolem 1) [var "z"]])),(pApp "f" [var "x",var "z"])],-                           [((.~.) (pApp "f" [var "x",fApp (toSkolem 1) [var "z"]])),((.~.) (pApp "f" [var "x",var "x"]))],-                           [((.~.) (pApp "f" [var "x",var "z"])),(pApp "f" [var "x",var "x"]),(pApp "f" [var "x",fApp (toSkolem 1) [var "z"]])]])]-      }-    , let f = pApp "f" -          q = pApp "q"-          sk1 = fApp (toSkolem 1)-          (x, y, z) = (var "x", var "y", var "z") in-      TestFormula-      { name = "cnf test 9"-      , formula = (for_all "x" (for_all "x" (for_all "y" (q [x, y] .<=>. for_all "z" (f [z, x] .<=>. f [z, y])))))-      , expected = [ClauseNormalForm-                    (toSS-                     [[(f [z,x]),-                       (f [sk1 [x,y],y]),-                       ((.~.) (f [z,y]))],-                      [(f [z,x]),-                       ((.~.) (f [z,y])),-                       ((.~.) (f [sk1 [x,y],x])),-                       ((.~.) (f [sk1 [x,y],y]))],-                      [(f [z,x]),-                       ((.~.) (f [z,y])),-                       ((.~.) (q [x,y]))],-                      [(f [z,y]),-                       (f [sk1 [x,y],y]),-                       ((.~.) (f [z,x]))],-                      [(f [z,y]),-                       ((.~.) (f [z,x])),-                       ((.~.) (f [sk1 [x,y],x])),-                       ((.~.) (f [sk1 [x,y],y]))],-                      [(f [z,y]),-                       ((.~.) (f [z,x])),-                       ((.~.) (q [x,y]))],-                      [(f [sk1 [x,y],y]),-                       (q [x,y])],-                      [(q [x,y]),-                       ((.~.) (f [sk1 [x,y],x])),-                       ((.~.) (f [sk1 [x,y],y]))]])-                   ]-      }-    , TestFormula-      { name = "cnf test 10"-      , formula = (for_all "x" (exists "y" ((p [x, y] .<=. for_all "x" (exists "z" (q [y, x, z]) .=>. r [y])))))-      , expected = [ClauseNormalForm-                    (toSS -                     [[(pApp ("p") [var ("x"),fApp (toSkolem 1) [var ("x")]]),-                       (pApp ("q") [fApp (toSkolem 1) [fApp (toSkolem 2) []],fApp (toSkolem 2) [],fApp (toSkolem 3) []])],-                      [(pApp ("p") [var ("x"),fApp (toSkolem 1) [var ("x")]]),-                       ((.~.) (pApp ("r") [fApp (toSkolem 1) [fApp (toSkolem 2) []]]))]])-                   ]-      }-    , TestFormula-      { name = "cnf test 11"-      , formula = (for_all "x" (for_all "z" (p [x, z] .=>. exists "y" ((.~.) (q [x, y] .|. ((.~.) (r [y, z])))))))-      , expected = [ClauseNormalForm-                    (toSS -                    [[((.~.) (pApp "p" [var "x",var "z"])),((.~.) (pApp "q" [var "x",fApp (toSkolem 1) [var "x",var "z"]]))],-                     [((.~.) (pApp "p" [var "x",var "z"])),(pApp "r" [fApp (toSkolem 1) [var "x",var "z"],var "z"])]])]-      }-    , TestFormula-      { name = "cnf test 12"-      , formula = ((p0 .=>. q0) .=>. (((.~.) r0) .=>. (s0 .&. t0)))-      , expected = [ClauseNormalForm-                    (toSS-                    [[(pApp "p" []),(pApp "r" []),(pApp "s" [])],-                     [((.~.) (pApp "q" [])),(pApp "r" []),(pApp "s" [])],-                     [(pApp "p" []),(pApp "r" []),(pApp "t" [])],-                     [((.~.) (pApp "q" [])),(pApp "r" []),(pApp "t" [])]])]-      }-    , let p = pApp "p" []-          true = pApp (fromBool True) []-          false = pApp (fromBool False) [] in-      TestFormula-      { name = "psimplify 50"-      , formula = true .=>. (p .<=>. (p .<=>. false))-      , expected = [ SimplifiedForm (p .<=>. (.~.) p) ] }-    , let true = pApp (fromBool True) []-          false = pApp (fromBool False) [] in-      TestFormula-      { name = "psimplify 51"-      , formula = (((pApp "x" [] .=>. pApp "y" []) .=>. true) .|. false)-      , expected = [ SimplifiedForm (pApp (fromBool True) []) ] }-    , let false = pApp (fromBool False) []-          q = pApp "q" [] in-      TestFormula-      { name = "simplify 140.3"-      , formula = (for_all "x"-                   (for_all "y"-                    (pApp "p" [var "x"] .|. (pApp "p" [var "y"] .&. false))) .=>.-                   (exists "z" q))-      , expected = [ SimplifiedForm ((for_all "x" (pApp "p" [var "x"])) .=>.-                                        (pApp "q" [])) ] }-    , TestFormula-      { name = "nnf 141.1"-      , formula = ((for_all "x" (pApp "p" [var "x"])) .=>. ((exists "y" (pApp "q" [var "y"])) .<=>. (exists "z" (pApp "p" [var "z"] .&. pApp "q" [var "z"]))))-      , expected = [ NegationNormalForm -                     ((exists "x" ((.~.) (pApp "p" [var "x"]))) .|.-                      ((((exists "y" (pApp "q" [var "y"])) .&. ((exists "z" ((pApp "p" [var "z"]) .&. ((pApp "q" [var "z"])))))) .|.-                        (((for_all "y" ((.~.) (pApp "q" [var "y"]))) .&.-                          ((for_all "z" (((.~.) (pApp "p" [var "z"])) .|. (((.~.) (pApp "q" [var "z"]))))))))))) ] }-    , TestFormula-      { name = "pnf 144.1"-      , formula = (for_all "x" (pApp "p" [var "x"] .|. pApp "r" [var "y"]) .=>.-                   (exists "y" (exists "z" (pApp "q" [var "y"] .|. ((.~.) (exists "z" (pApp "p" [var "z"] .&. pApp "q" [var "z"])))))))-      , expected = [ PrenexNormalForm -                     (exists "x" -                      (for_all "z"-                       ((((.~.) (pApp "p" [var "x"])) .&. (((.~.) (pApp "r" [var "y"])))) .|.-                        (((pApp "q" [var "x"]) .|. ((((.~.) (pApp "p" [var "z"])) .|. (((.~.) (pApp "q" [var "z"])))))))))) ] }-    , let (x, y, u, v) = (var "x", var "y", var "u", var "v")-          fv = fApp (toSkolem 2) [u,x]-          fy = fApp (toSkolem 1) [x] in-      TestFormula-      { name = "snf 150.1"-      , formula = (exists "y" (pApp "<" [x, y] .=>. for_all "u" (exists "v" (pApp "<" [fApp "*" [x, u], fApp "*" [y, v]]))))-      , expected = [ SkolemNormalForm (((.~.) (pApp "<" [x, fy])) .|. pApp "<" [fApp "*" [x, u], fApp "*" [fy, fv]]) ] }-    , let p x = pApp "p" [x]-          q x = pApp "q" [x]-          (x, y, z) = (var "x", var "y", var "z") in-      TestFormula-      { name = "snf 150.2"-      , formula = (for_all "x" (p x .=>. (exists "y" (exists "z" (q y .|. (.~.) (exists "z" (p z .&. (q z))))))))-      , expected = [ SkolemNormalForm (((.~.) (p x)) .|. (q (fApp (toSkolem 1) []) .|. (((.~.) (p z)) .|. ((.~.) (q z))))) ] }-    ]--animalKB :: forall formula term v p f. (FirstOrderFormula formula term v p f, Ord formula, IsString v, IsString p, IsString f) =>-            (String, [TestFormula formula term v p f])-animalKB =-    let x = var "x"-        y = var "y"-        dog = pApp "Dog"-        cat = pApp "Cat"-        owns = pApp "Owns"-        kills = pApp "Kills"-        animal = pApp "Animal"-        animalLover = pApp "AnimalLover"-        jack = fApp "Jack" []-        tuna = fApp "Tuna" []-        curiosity = fApp "Curiosity" [] in-    ("animal"-    , [ TestFormula-       { formula = exists "x" (dog [x] .&. owns [jack, x]) -- [[Pos 1],[Pos 2]]-       , name = "jack owns a dog"-       , expected = [ClauseNormalForm (toSS [[(pApp "Dog" [fApp (toSkolem 1) []])],[(pApp "Owns" [fApp "Jack" [],fApp (toSkolem 1) []])]])]-       -- owns(jack,sK0)-       -- dog (SK0)-                   }-     , TestFormula-       { formula = for_all "x" ((exists "y" (dog [y] .&. (owns [x, y]))) .=>. (animalLover [x])) -- [[Neg 1,Neg 2,Pos 3]]-       , name = "dog owners are animal lovers"-       , expected = [ PrenexNormalForm (for_all "x" (for_all "y" ((((.~.) (pApp "Dog" [var "y"])) .|.-                                                                           (((.~.) (pApp "Owns" [var "x",var "y"])))) .|.-                                                                          ((pApp "AnimalLover" [var "x"])))))-                    , ClauseNormalForm (toSS [[((.~.) (pApp "Dog" [var "y"])),((.~.) (pApp "Owns" [var "x",var "y"])),(pApp "AnimalLover" [var "x"])]]) ]-       -- animalLover(X0) | ~owns(X0,sK1(X0)) | ~dog(sK1(X0))-       }-     , TestFormula-       { formula = for_all "x" (animalLover [x] .=>. (for_all "y" ((animal [y]) .=>. ((.~.) (kills [x, y]))))) -- [[Neg 3,Neg 4,Neg 5]]-       , name = "animal lovers don't kill animals"-       , expected = [ClauseNormalForm  (toSS [[((.~.) (pApp "AnimalLover" [var "x"])),((.~.) (pApp "Animal" [var "y"])),((.~.) (pApp "Kills" [var "x",var "y"]))]])]-       -- ~kills(X0,X2) | ~animal(X2) | ~animalLover(sK2(X0))-       }-     , TestFormula-       { formula = (kills [jack, tuna]) .|. (kills [curiosity, tuna]) -- [[Pos 5,Pos 5]]-       , name = "Either jack or curiosity kills tuna"-       , expected = [ClauseNormalForm  (toSS [[(pApp "Kills" [fApp "Jack" [],fApp "Tuna" []]),(pApp "Kills" [fApp "Curiosity" [],fApp "Tuna" []])]])]-       -- kills(curiosity,tuna) | kills(jack,tuna)-       }-     , TestFormula-       { formula = cat [tuna] -- [[Pos 6]]-       , name = "tuna is a cat"-       , expected = [ClauseNormalForm  (toSS [[(pApp "Cat" [fApp "Tuna" []])]])]-       -- cat(tuna)-       }-     , TestFormula-       { formula = for_all "x" ((cat [x]) .=>. (animal [x])) -- [[Neg 6,Pos 4]]-       , name = "a cat is an animal"-       , expected = [ClauseNormalForm  (toSS [[((.~.) (pApp "Cat" [var "x"])),(pApp "Animal" [var "x"])]])]-       -- animal(X0) | ~cat(X0)-       }-     ])--animalConjectures :: forall formula term v p f. (FirstOrderFormula formula term v p f, Ord formula, IsString v, IsString p, IsString f) =>-                     [TestFormula formula term v p f]-animalConjectures =-    let kills = pApp "Kills" :: [term] -> formula-        jack = fApp "Jack" [] :: term-        tuna = fApp "Tuna" [] :: term-        curiosity = fApp "Curiosity" [] :: term in--    map (withKB animalKB) $-     [ TestFormula-       { formula = kills [jack, tuna]             -- False-       , name = "jack kills tuna"-       , expected =-           [ FirstOrderFormula ((.~.) (((exists "x" ((pApp "Dog" [var ("x")]) .&. ((pApp "Owns" [fApp ("Jack") [],var ("x")])))) .&.-                                        (((for_all "x" ((exists "y" ((pApp "Dog" [var ("y")]) .&. ((pApp "Owns" [var ("x"),var ("y")])))) .=>.-                                                          ((pApp "AnimalLover" [var ("x")])))) .&.-                                          (((for_all "x" ((pApp "AnimalLover" [var ("x")]) .=>.-                                                            ((for_all "y" ((pApp "Animal" [var ("y")]) .=>.-                                                                             (((.~.) (pApp "Kills" [var ("x"),var ("y")])))))))) .&.-                                            ((((pApp "Kills" [fApp ("Jack") [],fApp ("Tuna") []]) .|. ((pApp "Kills" [fApp ("Curiosity") [],fApp ("Tuna") []]))) .&.-                                              (((pApp "Cat" [fApp ("Tuna") []]) .&.-                                                ((for_all "x" ((pApp "Cat" [var ("x")]) .=>.-                                                                 ((pApp "Animal" [var ("x")])))))))))))))) .=>.-                                       ((pApp "Kills" [fApp ("Jack") [],fApp ("Tuna") []]))))--           , PrenexNormalForm-             (for_all "x"-              (for_all "y"-               (exists "x2"-                ((((pApp ("Dog") [var ("x2")]) .&.-                   ((pApp ("Owns") [fApp ("Jack") [],var ("x2")]))) .&.-                  ((((((.~.) (pApp ("Dog") [var ("y")])) .|.-                      (((.~.) (pApp ("Owns") [var ("x"),var ("y")])))) .|.-                     ((pApp ("AnimalLover") [var ("x")]))) .&.-                    (((((.~.) (pApp ("AnimalLover") [var ("x")])) .|.-                       ((((.~.) (pApp ("Animal") [var ("y")])) .|.-                         (((.~.) (pApp ("Kills") [var ("x"),var ("y")])))))) .&.-                      ((((pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []]) .|.-                         ((pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []]))) .&.-                        (((pApp ("Cat") [fApp ("Tuna") []]) .&.-                          ((((.~.) (pApp ("Cat") [var ("x")])) .|.-                            ((pApp ("Animal") [var ("x")]))))))))))))) .&.-                 (((.~.) (pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])))))))-           , ClauseNormalForm-             (toSS-              [[(pApp ("Animal") [var ("x")]),-                ((.~.) (pApp ("Cat") [var ("x")]))],-               [(pApp ("AnimalLover") [var ("x")]),-                ((.~.) (pApp ("Dog") [var ("y")])),-                ((.~.) (pApp ("Owns") [var ("x"),var ("y")]))],-               [(pApp ("Cat") [fApp ("Tuna") []])],-               [(pApp ("Dog") [fApp (toSkolem 1) []])],-               [(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []]),-                (pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])],-               [(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem 1) []])],-               [((.~.) (pApp ("Animal") [var ("y")])),-                ((.~.) (pApp ("AnimalLover") [var ("x")])),-                ((.~.) (pApp ("Kills") [var ("x"),var ("y")]))],-               [((.~.) (pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []]))]])-           , ChiouKB1-             (Proof-              Invalid-              (S.fromList -               [makeINF' ([]) ([(pApp ("Cat") [fApp ("Tuna") []])]),-                makeINF' ([]) ([(pApp ("Dog") [fApp (toSkolem 1) []])]),-                makeINF' ([]) ([(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []]),(pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])]),-                makeINF' ([]) ([(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem 1) []])]),-                makeINF' ([(pApp ("Animal") [var ("y")]),(pApp ("AnimalLover") [var ("x")]),(pApp ("Kills") [var ("x"),var ("y")])]) ([]),-                makeINF' ([(pApp ("Cat") [var ("x")])]) ([(pApp ("Animal") [var ("x")])]),-                makeINF' ([(pApp ("Dog") [var ("y")]),(pApp ("Owns") [var ("x"),var ("y")])]) ([(pApp ("AnimalLover") [var ("x")])]),-                makeINF' ([(pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])]) ([])]))-           ]-       }-     , TestFormula-       { formula = kills [curiosity, tuna]        -- True-       , name = "curiosity kills tuna"-       , expected =-           [ ClauseNormalForm-             (toSS-             [[(pApp "Dog" [fApp (toSkolem 1) []])],-              [(pApp "Owns" [fApp ("Jack") [],fApp (toSkolem 1) []])],-              [((.~.) (pApp "Dog" [var ("y")])),-               ((.~.) (pApp "Owns" [var ("x"),var ("y")])),-               (pApp "AnimalLover" [var ("x")])],-              [((.~.) (pApp "AnimalLover" [var ("x")])),-               ((.~.) (pApp "Animal" [var ("y")])),-               ((.~.) (pApp "Kills" [var ("x"),var ("y")]))],-              [(pApp "Kills" [fApp ("Jack") [],fApp ("Tuna") []]),-               (pApp "Kills" [fApp ("Curiosity") [],fApp ("Tuna") []])],-              [(pApp "Cat" [fApp ("Tuna") []])],-              [((.~.) (pApp "Cat" [var ("x")])),-               (pApp "Animal" [var ("x")])],-              [((.~.) (pApp "Kills" [fApp "Curiosity" [],fApp "Tuna" []]))]])-           , PropLogicSat True-{--           , SatSolverCNF [ [Neg 1,Neg 2,Neg 3]    -- animallover(x)|animal(y)|kills(x,y)-                          , [Neg 4,Pos 5]          -- ~cat(x)|animal(x)-                          , [Neg 6,Neg 7,Pos 2]    -- ~dog(y)|~owns(x,y)|animallover(x)-                          , [Neg 8]                -- ~kills(curisity,tuna)-                          , [Pos 8,Pos 11]         -- kills(curiosity,tuna)|kills(jack,tuna)-                          , [Pos 9]                -- cat(tuna)-                          , [Pos 10]               -- owns(jack,sk1)-                          , [Pos 12]               -- dog(sk1)-                          ]--}-           -- I haven't tried to figure out if this is correct, it-           -- probably is because things are working.-           , SatSolverCNF [[Neg 2,Pos 1],[Neg 3,Neg 11,Neg 12],[Neg 4,Neg 5,Pos 3],[Neg 8],[Pos 6],[Pos 7],[Pos 8,Pos 9],[Pos 10]]-           -- It seems like this should be True.-           , SatSolverSat False-           ]-       }-     ]--socratesKB =-    let x = var "x"-        socrates x = pApp "Socrates" [x]-        human x = pApp "Human" [x]-        mortal x = pApp "Mortal" [x] in-    ("socrates"-    , [ TestFormula-       { name = "all humans are mortal"-       , formula = for_all "x" (human x .=>. mortal x)-       , expected = [ClauseNormalForm  (toSS [[((.~.) (human x)), mortal x]])] }-     , TestFormula-       { name = "socrates is human"-       , formula = for_all "x" (socrates x .=>. human x)-       , expected = [ClauseNormalForm  (toSS [[(.~.) (socrates x), human x]])] }-     ])--{--socratesConjectures =-    map (withKB socratesKB)-     [ TestFormula-       { formula = for_all' [V "x"] (socrates x .=>. mortal x)-       , name = "socrates is mortal"-       , expected = [ FirstOrderFormula ((.~.) (((for_all' [V "x"] ((pApp "Human" [var "x"]) .=>. ((pApp "Mortal" [var "x"])))) .&.-                                                 ((for_all' [V "x"] ((pApp "Socrates" [var "x"]) .=>. ((pApp "Human" [var "x"])))))) .=>.-                                                ((for_all' [V "x"] ((pApp "Socrates" [var "x"]) .=>. ((pApp "Mortal" [var "x"])))))))-                    , ClauseNormalForm  [[((.~.) (pApp "Human" [var "x2"])),(pApp "Mortal" [var "x2"])],-                                          [((.~.) (pApp "Socrates" [var "x2"])),(pApp "Human" [var "x2"])],-                                          [(pApp "Socrates" [fApp (toSkolem 1) [var "x2",var "x2"]])],-                                          [((.~.) (pApp "Mortal" [fApp (toSkolem 1) [var "x2",var "x2"]]))]]-                    , SatPropLogic True ]-       }-     , TestFormula-       { formula = (.~.) (for_all' [V "x"] (socrates x .=>. mortal x))-       , name = "not (socrates is mortal)"-       , expected = [ SatPropLogic False-                    , FirstOrderFormula ((.~.) (((for_all' [V "x"] ((pApp "Human" [var "x"]) .=>. ((pApp "Mortal" [var "x"])))) .&.-                                                 ((for_all' [V "x"] ((pApp "Socrates" [var "x"]) .=>. ((pApp "Human" [var "x"])))))) .=>.-                                                (((.~.) (for_all' [V "x"] ((pApp "Socrates" [var "x"]) .=>. ((pApp "Mortal" [var "x"]))))))))-                    -- [~human(x) | mortal(x)], [~socrates(Sk1(x,y)) | human(Sk1(x,y))], socrates(Sk1(x,y)), ~mortal(Sk1(x,y))-                    -- ~1 | 2, ~3 | 4, 3, ~5?-                    , ClauseNormalForm [[((.~.) (pApp "Human" [x])), (pApp "Mortal" [x])],-                                         [((.~.) (pApp "Socrates" [fApp (toSkolem 1) [x,y]])), (pApp "Human" [fApp (toSkolem 1) [x,y]])],-                                         [(pApp "Socrates" [fApp (toSkolem 1) [x,y]])], [((.~.) (pApp "Mortal" [fApp (toSkolem 1) [x,y]]))]]-                    , ClauseNormalForm [[((.~.) (pApp "Human" [var "x2"])), (pApp "Mortal" [var "x2"])],-                                         [((.~.) (pApp "Socrates" [var "x2"])), (pApp "Human" [var "x2"])],-                                         [((.~.) (pApp "Socrates" [var "x"])), (pApp "Mortal" [var "x"])]] ]-       }-     ]--}--chang43KB = -    let e = fApp "e" []-        (x, y, z, u, v, w) = (var "x", var "y", var "z", var "u", var "v", var "w") in-    ("chang example 4.3"-    , [ TestFormula { name = "closure property"-                    , formula = for_all' ["x", "y"] (exists "z" (pApp "P" [x,y,z]))-                    , expected = [] }-      , TestFormula { name = "associativity property"-                    , formula = for_all' ["x", "y", "z", "u", "v", "w"] (pApp "P" [x, y, u] .&. pApp "P" [y, z, v] .&. pApp "P" [u, z, w] .=>. pApp "P" [x, v, w]) .&.-                                for_all' ["x", "y", "z", "u", "v", "w"] (pApp "P" [x, y, u] .&. pApp "P" [y, z, v] .&. pApp "P" [x, v, w] .=>. pApp "P" [u, z, w])-                    , expected = [] }-      , TestFormula { name = "identity property"-                    , formula = (for_all "x" (pApp "P" [x,e,x])) .&. (for_all "x" (pApp "P" [e,x,x]))-                    , expected = [] }-      , TestFormula { name = "inverse property"-                    , formula = (for_all "x" (pApp "P" [x,fApp "i" [x], e])) .&. (for_all "x" (pApp "P" [fApp "i" [x], x, e]))-                    , expected = [] }-      ])--chang43Conjecture :: forall formula term v p f. (FirstOrderFormula formula term v p f, Ord formula, IsString v, IsString p, IsString f) =>-                     TestFormula formula term v p f-chang43Conjecture =-    let e = (fApp "e" [])-        (x, u, v, w) = (var "x", var "u", var "v", var "w") in-    withKB chang43KB $-    TestFormula { name = "G is commutative"-                , formula = for_all "x" (pApp "P" [x, x, e] .=>. (for_all' ["u", "v", "w"] (pApp "P" [u, v, w] .=>. pApp "P" [v, u, w]))) -                , expected =-                    [ FirstOrderFormula -                      ((.~.) (((for_all' ["x","y"] (exists "z" (pApp "P" [var ("x"),var ("y"),var ("z")]))) .&. ((((for_all' ["x","y","z","u","v","w"] ((((pApp "P" [var ("x"),var ("y"),var ("u")]) .&. ((pApp "P" [var ("y"),var ("z"),var ("v")]))) .&. ((pApp "P" [var ("u"),var ("z"),var ("w")]))) .=>. ((pApp "P" [var ("x"),var ("v"),var ("w")])))) .&. ((for_all' ["x","y","z","u","v","w"] ((((pApp "P" [var ("x"),var ("y"),var ("u")]) .&. ((pApp "P" [var ("y"),var ("z"),var ("v")]))) .&. ((pApp "P" [var ("x"),var ("v"),var ("w")]))) .=>. ((pApp "P" [var ("u"),var ("z"),var ("w")])))))) .&. ((((for_all "x" (pApp "P" [var ("x"),fApp ("e") [],var ("x")])) .&. ((for_all "x" (pApp "P" [fApp ("e") [],var ("x"),var ("x")])))) .&. (((for_all "x" (pApp "P" [var ("x"),fApp ("i") [var ("x")],fApp ("e") []])) .&. ((for_all "x" (pApp "P" [fApp ("i") [var ("x")],var ("x"),fApp ("e") []])))))))))) .=>. ((for_all "x" ((pApp "P" [var ("x"),var ("x"),fApp ("e") []]) .=>. ((for_all' ["u","v","w"] ((pApp "P" [var ("u"),var ("v"),var ("w")]) .=>. ((pApp "P" [var ("v"),var ("u"),var ("w")]))))))))))-                      -- (∀x ∀y ∃z P(x,y,z)) &-                      -- (∀x∀y∀z∀u∀v∀w ~P(x,y,u) | ~P(y,z,v) | ~P(u,z,w) | P(x,v,w)) &-                      -- (∀x∀y∀z∀u∀v∀w ~P(x,y,u) | ~P(y,z,v) | ~P(x,v,w) | P(u,z,w)) &-                      -- (∀x P(x,e,x)) &-                      -- (∀x P(e,x,x)) &-                      -- (∀x P(x,i[x],e)) &-                      -- (∀x P(i[x],x,e)) &-                      -- (∃x P(x,x,e) & (∃u∃v∃w P(u,v,w) & ~P(v,u,w)))-                    , NegationNormalForm-                      (((for_all "x"-                         (for_all "y"-                          (exists "z"-                           (pApp ("P") [var ("x"),var ("y"),var ("z")])))) .&.-                        ((((for_all "x"-                            (for_all "y"-                             (for_all "z"-                              (for_all "u"-                               (for_all "v"-                                (for_all "w"-                                 (((((.~.) (pApp ("P") [var ("x"),var ("y"),var ("u")])) .|.-                                    (((.~.) (pApp ("P") [var ("y"),var ("z"),var ("v")])))) .|.-                                   (((.~.) (pApp ("P") [var ("u"),var ("z"),var ("w")])))) .|.-                                  ((pApp ("P") [var ("x"),var ("v"),var ("w")]))))))))) .&.-                           ((for_all "x"-                             (for_all "y"-                              (for_all "z"-                               (for_all "u"-                                (for_all "v"-                                 (for_all "w"-                                  (((((.~.) (pApp ("P") [var ("x"),var ("y"),var ("u")])) .|.-                                     (((.~.) (pApp ("P") [var ("y"),var ("z"),var ("v")])))) .|.-                                    (((.~.) (pApp ("P") [var ("x"),var ("v"),var ("w")])))) .|.-                                   ((pApp ("P") [var ("u"),var ("z"),var ("w")]))))))))))) .&.-                          ((((for_all "x" (pApp ("P") [var ("x"),fApp ("e") [],var ("x")])) .&.-                             ((for_all "x" (pApp ("P") [fApp ("e") [],var ("x"),var ("x")])))) .&.-                            (((for_all "x" (pApp ("P") [var ("x"),fApp ("i") [var ("x")],fApp ("e") []])) .&.-                              ((for_all "x" (pApp ("P") [fApp ("i") [var ("x")],var ("x"),fApp ("e") []])))))))))) .&.-                       ((exists "x"-                         ((pApp ("P") [var ("x"),var ("x"),fApp ("e") []]) .&.-                          ((exists "u"-                            (exists "v"-                             (exists "w"-                              ((pApp ("P") [var ("u"),var ("v"),var ("w")]) .&.-                               (((.~.) (pApp ("P") [var ("v"),var ("u"),var ("w")]))))))))))))-                    , PrenexNormalForm-                      (for_all "x"-                       (for_all "y"-                        (for_all "z"-                         (for_all "u"-                          (for_all "v"-                           (for_all "w"-                            (exists "z2"-                             (exists "x2"-                              (exists "u2"-                               (exists "v2"-                                (exists "w2"-                                 (((pApp ("P") [var ("x"),var ("y"),var ("z2")]) .&.-                                   ((((((((.~.) (pApp ("P") [var ("x"),var ("y"),var ("u")])) .|.-                                         (((.~.) (pApp ("P") [var ("y"),var ("z"),var ("v")])))) .|.-                                        (((.~.) (pApp ("P") [var ("u"),var ("z"),var ("w")])))) .|.-                                       ((pApp ("P") [var ("x"),var ("v"),var ("w")]))) .&.-                                      ((((((.~.) (pApp ("P") [var ("x"),var ("y"),var ("u")])) .|.-                                          (((.~.) (pApp ("P") [var ("y"),var ("z"),var ("v")])))) .|.-                                         (((.~.) (pApp ("P") [var ("x"),var ("v"),var ("w")])))) .|.-                                        ((pApp ("P") [var ("u"),var ("z"),var ("w")]))))) .&.-                                     ((((pApp ("P") [var ("x"),fApp ("e") [],var ("x")]) .&.-                                        ((pApp ("P") [fApp ("e") [],var ("x"),var ("x")]))) .&.-                                       (((pApp ("P") [var ("x"),fApp ("i") [var ("x")],fApp ("e") []]) .&.-                                         ((pApp ("P") [fApp ("i") [var ("x")],var ("x"),fApp ("e") []]))))))))) .&.-                                  (((pApp ("P") [var ("x2"),var ("x2"),fApp ("e") []]) .&.-                                    (((pApp ("P") [var ("u2"),var ("v2"),var ("w2")]) .&.-                                      (((.~.) (pApp ("P") [var ("v2"),var ("u2"),var ("w2")])))))))))))))))))))-                    , SkolemNormalForm-                      (((pApp ("P") [var ("x"),var ("y"),fApp (toSkolem 1) [var ("x"),var ("y")]]) .&.-                        ((((((((.~.) (pApp ("P") [var ("x"),var ("y"),var ("u")])) .|.-                              (((.~.) (pApp ("P") [var ("y"),var ("z"),var ("v")])))) .|.-                             (((.~.) (pApp ("P") [var ("u"),var ("z"),var ("w")])))) .|.-                            ((pApp ("P") [var ("x"),var ("v"),var ("w")]))) .&.-                           ((((((.~.) (pApp ("P") [var ("x"),var ("y"),var ("u")])) .|.-                               (((.~.) (pApp ("P") [var ("y"),var ("z"),var ("v")])))) .|.-                              (((.~.) (pApp ("P") [var ("x"),var ("v"),var ("w")])))) .|.-                             ((pApp ("P") [var ("u"),var ("z"),var ("w")]))))) .&.-                          ((((pApp ("P") [var ("x"),fApp ("e") [],var ("x")]) .&.-                             ((pApp ("P") [fApp ("e") [],var ("x"),var ("x")]))) .&.-                            (((pApp ("P") [var ("x"),fApp ("i") [var ("x")],fApp ("e") []]) .&.-                              ((pApp ("P") [fApp ("i") [var ("x")],var ("x"),fApp ("e") []]))))))))) .&.-                       (((pApp ("P") [fApp (toSkolem 2) [],fApp (toSkolem 2) [],fApp ("e") []]) .&.-                         (((pApp ("P") [fApp (toSkolem 3) [],fApp (toSkolem 4) [],fApp (toSkolem 5) []]) .&.-                           (((.~.) (pApp ("P") [fApp (toSkolem 4) [],fApp (toSkolem 3) [],fApp (toSkolem 5) []]))))))))-                    , SkolemNumbers (S.fromList [1,2,3,4,5])-                    -- From our algorithm--                    , ClauseNormalForm-                      (toSS -                      [[(pApp ("P") [var ("x"),var ("y"),fApp (toSkolem 1) [var ("x"),var ("y")]])],-                       [((.~.) (pApp ("P") [var ("x"),var ("y"),var ("u")])),-                        ((.~.) (pApp ("P") [var ("y"),var ("z"),var ("v")])),-                        ((.~.) (pApp ("P") [var ("u"),var ("z"),var ("w")])),-                        (pApp ("P") [var ("x"),var ("v"),var ("w")])],-                       [((.~.) (pApp ("P") [var ("x"),var ("y"),var ("u")])),-                        ((.~.) (pApp ("P") [var ("y"),var ("z"),var ("v")])),-                        ((.~.) (pApp ("P") [var ("x"),var ("v"),var ("w")])),-                        (pApp ("P") [var ("u"),var ("z"),var ("w")])],-                       [(pApp ("P") [var ("x"),fApp ("e") [],var ("x")])],-                       [(pApp ("P") [fApp ("e") [],var ("x"),var ("x")])],-                       [(pApp ("P") [var ("x"),fApp ("i") [var ("x")],fApp ("e") []])],-                       [(pApp ("P") [fApp ("i") [var ("x")],var ("x"),fApp ("e") []])],-                       [(pApp ("P") [fApp (toSkolem 2) [],fApp (toSkolem 2) [],fApp ("e") []])],-                       [(pApp ("P") [fApp (toSkolem 3) [],fApp (toSkolem 4) [],fApp (toSkolem 5) []])],-                       [((.~.) (pApp ("P") [fApp (toSkolem 4) [],fApp (toSkolem 3) [],fApp (toSkolem 5) []]))]])--                    -- From the book-{--                    , let (a, b, c) = -                              (fApp (toSkolem 3) [var ("x"),var ("y"),var ("x2"),var ("y2"),var ("z2"),var ("u"),var ("v"),var ("w"),var ("x2"),var ("y2"),var ("z2"),var ("u2"),var ("v2"),var ("w2"),var ("x3"),var ("x3"),var ("x3"),var ("x3")],-                               fApp (toSkolem 4) [var ("x"),var ("y"),var ("x2"),var ("y2"),var ("z2"),var ("u"),var ("v"),var ("w"),var ("x2"),var ("y2"),var ("z2"),var ("u2"),var ("v2"),var ("w2"),var ("x3"),var ("x3"),var ("x3"),var ("x3")],-                               fApp (toSkolem 5) [var ("x"),var ("y"),var ("x2"),var ("y2"),var ("z2"),var ("u"),var ("v"),var ("w"),var ("x2"),var ("y2"),var ("z2"),var ("u2"),var ("v2"),var ("w2"),var ("x3"),var ("x3"),var ("x3"),var ("x3")]) in-                      ClauseNormalForm-                      [[(pApp "P" [var "x",var "y",fApp (toSkolem 1) [var "x",var "y"]])],-                       [((.~.) (pApp "P" [var "x",var "y",var "u"])),-                        ((.~.) (pApp "P" [var "y",var "z",var "v"])),-                        ((.~.) (pApp "P" [var "u",var "z",var "w"])),-                        (pApp "P" [var "x",var "v",var "w"])],-                       [((.~.) (pApp "P" [var "x",var "y",var "u"])),-                        ((.~.) (pApp "P" [var "y",var "z",var "v"])),-                        ((.~.) (pApp "P" [var "x",var "v",var "w"])),-                        (pApp "P" [var "u",var "z",var "w"])],-                       [(pApp "P" [var "x",fApp "e" [],var "x"])],-                       [(pApp "P" [fApp "e" [],var "x",var "x"])],-                       [(pApp "P" [var "x",fApp "i" [var "x"],fApp "e" []])],-                       [(pApp "P" [fApp "i" [var "x"],var "x",fApp "e" []])],-                       [(pApp "P" [var "x",-                                   var "x",-                                   fApp "e" []])],-                       [(pApp "P" [a, b, c])],-                       [((.~.) (pApp "P" [b, a, c]))]]--}-                    ]-                }--{--% ghci-> :load Test/Data.hs-> :m +Logic.FirstOrder-> :m +Logic.Normal-> let f = (.~.) (conj (map formula (snd chang43KB)) .=>. formula chang43Conjecture)-> putStrLn (runNormal (cnfTrace f))--}--chang43ConjectureRenamed :: forall formula term v p f. (FirstOrderFormula formula term v p f, Ord formula, IsString v, IsString p, IsString f) =>-                            TestFormula formula term v p f-chang43ConjectureRenamed =-    let e = fApp "e" []-        (x, y, z, u, v, w) = (var "x", var "y", var "z", var "u", var "v", var "w")-        (u2, v2, w2, x2, y2, z2, u3, v3, w3, x3, y3, z3, x4, x5, x6, x7, x8) =-            (var "u2", var "v2", var "w2", var "x2", var "y2", var "z2", var "u3", var "v3", var "w3", var "x3", var "y3", var "z3", var "x4", var "x5", var "x6", var "x7", var "x8") in-    TestFormula { name = "chang 43 renamed"-                , formula = (.~.) ((for_all' ["x", "y"] (exists "z" (pApp "P" [x,y,z])) .&.-                                    for_all' ["x2", "y2", "z2", "u", "v", "w"] (pApp "P" [x2, y2, u] .&. pApp "P" [y2, z2, v] .&. pApp "P" [u, z2, w] .=>. pApp "P" [x2, v, w]) .&.-                                    for_all' ["x3", "y3", "z3", "u2", "v2", "w2"] (pApp "P" [x3, y3, u2] .&. pApp "P" [y3, z3, v2] .&. pApp "P" [x3, v2, w2] .=>. pApp "P" [u2, z3, w2]) .&.-                                    for_all "x4" (pApp "P" [x4,e,x4]) .&.-                                    for_all "x5" (pApp "P" [e,x5,x5]) .&.-                                    for_all "x6" (pApp "P" [x6,fApp "i" [x6], e]) .&.-                                    for_all "x7" (pApp "P" [fApp "i" [x7], x7, e])) .=>.-                                   (for_all "x8" (pApp "P" [x8, x8, e] .=>. (for_all' ["u3", "v3", "w3"] (pApp "P" [u3, v3, w3] .=>. pApp "P" [v3, u3, w3])))))-                , expected =-                    [ FirstOrderFormula-                      ((.~.) ((((((((for_all' ["x","y"] (exists "z" (pApp "P" [var "x",var "y",var "z"]))) .&.-                                    ((for_all' ["x2","y2","z2","u","v","w"] ((((pApp "P" [var "x2",var "y2",var "u"]) .&.-                                                                                          ((pApp "P" [var "y2",var "z2",var "v"]))) .&.-                                                                                         ((pApp "P" [var "u",var "z2",var "w"]))) .=>.-                                                                                        ((pApp "P" [var "x2",var "v",var "w"])))))) .&.-                                   ((for_all' ["x3","y3","z3","u2","v2","w2"] ((((pApp "P" [var "x3",var "y3",var "u2"]) .&.-                                                                                            ((pApp "P" [var "y3",var "z3",var "v2"]))) .&.-                                                                                           ((pApp "P" [var "x3",var "v2",var "w2"]))) .=>.-                                                                                          ((pApp "P" [var "u2",var "z3",var "w2"])))))) .&.-                                  ((for_all "x4" (pApp "P" [var "x4",fApp "e" [],var "x4"])))) .&.-                                 ((for_all "x5" (pApp "P" [fApp "e" [],var "x5",var "x5"])))) .&.-                                ((for_all "x6" (pApp "P" [var "x6",fApp "i" [var "x6"],fApp "e" []])))) .&.-                               ((for_all "x7" (pApp "P" [fApp "i" [var "x7"],var "x7",fApp "e" []])))) .=>.-                              ((for_all "x8" ((pApp "P" [var "x8",var "x8",fApp "e" []]) .=>.-                                                  ((for_all' ["u3","v3","w3"] ((pApp "P" [var "u3",var "v3",var "w3"]) .=>.-                                                                                    ((pApp "P" [var "v3",var "u3",var "w3"]))))))))))-                    , let a = fApp (toSkolem 3) []-                          b = fApp (toSkolem 4) []-                          c = fApp (toSkolem 5) [] in-                      ClauseNormalForm-                      (toSS-                      [[(pApp ("P") [var ("x"),var ("y"),fApp (toSkolem 1) [var ("x"),var ("y")]])],-                       [((.~.) (pApp ("P") [var ("x"),var ("y"),var ("u")])),-                        ((.~.) (pApp ("P") [var ("y"),var ("z2"),var ("v")])),-                        ((.~.) (pApp ("P") [var ("u"),var ("z2"),var ("w")])),-                        (pApp ("P") [var ("x"),var ("v"),var ("w")])],-                       [((.~.) (pApp ("P") [var ("x"),var ("y"),var ("u")])),-                        ((.~.) (pApp ("P") [var ("y"),var ("z2"),var ("v")])),-                        ((.~.) (pApp ("P") [var ("x"),var ("v"),var ("w")])),-                        (pApp ("P") [var ("u"),var ("z2"),var ("w")])],-                       [(pApp ("P") [var ("x"),fApp ("e") [],var ("x")])],-                       [(pApp ("P") [fApp ("e") [],var ("x"),var ("x")])],-                       [(pApp ("P") [var ("x"),fApp ("i") [var ("x")],fApp ("e") []])],-                       [(pApp ("P") [fApp ("i") [var ("x")],var ("x"),fApp ("e") []])],-                       [(pApp ("P") [fApp (toSkolem 2) [],fApp (toSkolem 2) [],fApp ("e") []])],-                       [(pApp ("P") [a,b,c])],-                       [((.~.) (pApp ("P") [b,a,c]))]])                      -                    ]-                }--withKB :: forall formula term v p f. (FirstOrderFormula formula term v p f) =>-          (String, [TestFormula formula term v p f]) -> TestFormula formula term v p f -> TestFormula formula term v p f-withKB (kbName, knowledge) conjecture =-    conjecture { name = name conjecture ++ " with " ++ kbName ++ " knowledge base"-               -- Here we say that the conjunction of the knowledge-               -- base formula implies the conjecture.  We prove the-               -- theorem by showing that the negation is-               -- unsatisfiable.-               , formula = (.~.) (conj (map formula knowledge) .=>. formula conjecture)}-    where-      conj [] = error "conj []"-      conj [x] = x-      conj (x:xs) = x .&. conj xs--kbKnowledge :: forall formula term v p f. (FirstOrderFormula formula term v p f) =>-               (String, [TestFormula formula term v p f]) -> (String, [formula])-kbKnowledge kb = (fst (kb :: (String, [TestFormula formula term v p f])), map formula (snd kb))--proofs :: forall formula term v p f. (FirstOrderFormula formula term v p f, Ord formula, IsString v, IsString p, IsString f) =>-          [TestProof formula term v]-proofs =-    let -- dog = pApp "Dog" :: [term] -> formula-        -- cat = pApp "Cat" :: [term] -> formula-        -- owns = pApp "Owns" :: [term] -> formula-        kills = pApp "Kills" :: [term] -> formula-        -- animal = pApp "Animal" :: [term] -> formula-        -- animalLover = pApp "AnimalLover" :: [term] -> formula-        socrates = pApp "Socrates" :: [term] -> formula-        -- human = pApp "Human" :: [term] -> formula-        mortal = pApp "Mortal" :: [term] -> formula--        jack :: term-        jack = fApp "Jack" []-        tuna :: term-        tuna = fApp "Tuna" []-        curiosity :: term-        curiosity = fApp "Curiosity" [] in--    [ TestProof-      { proofName = "prove jack kills tuna"-      , proofKnowledge = kbKnowledge (animalKB :: (String, [TestFormula formula term v p f]))-      , conjecture = kills [jack, tuna]-      , proofExpected = -          [ ChiouKB (S.fromList-                     [WithId {wiItem = INF (S.fromList []) (S.fromList [(pApp "Dog" [fApp (toSkolem 1) []])]), wiIdent = 1},-                      WithId {wiItem = INF (S.fromList []) (S.fromList [(pApp "Owns" [fApp "Jack" [],fApp (toSkolem 1) []])]), wiIdent = 1},-                      WithId {wiItem = INF (S.fromList [(pApp "Dog" [var "y"]),(pApp "Owns" [var "x",var "y"])]) (S.fromList [(pApp "AnimalLover" [var "x"])]), wiIdent = 2},-                      WithId {wiItem = INF (S.fromList [(pApp "Animal" [var "y"]),(pApp "AnimalLover" [var "x"]),(pApp "Kills" [var "x",var "y"])]) (S.fromList []), wiIdent = 3},-                      WithId {wiItem = INF (S.fromList []) (S.fromList [(pApp "Kills" [fApp "Curiosity" [],fApp "Tuna" []]),(pApp "Kills" [fApp "Jack" [],fApp "Tuna" []])]), wiIdent = 4},-                      WithId {wiItem = INF (S.fromList []) (S.fromList [(pApp "Cat" [fApp "Tuna" []])]), wiIdent = 5},-                      WithId {wiItem = INF (S.fromList [(pApp "Cat" [var "x"])]) (S.fromList [(pApp "Animal" [var "x"])]), wiIdent = 6}])-          , ChiouResult (False,-                         (S.fromList-                          [(inf' [(pApp "Kills" [fApp "Jack" [],fApp "Tuna" []])] [],fromList []),-                           (inf' [] [(pApp "Kills" [fApp "Curiosity" [],fApp "Tuna" []])],fromList []),-                           (inf' [(pApp "Animal" [fApp "Tuna" []]),(pApp "AnimalLover" [fApp "Curiosity" []])] [],fromList []),-                           (inf' [(pApp "Animal" [fApp "Tuna" []]),(pApp "Dog" [var "y"]),(pApp "Owns" [fApp "Curiosity" [],var "y"])] [],fromList []),-                           (inf' [(pApp "AnimalLover" [fApp "Curiosity" []]),(pApp "Cat" [fApp "Tuna" []])] [],fromList []),-                           (inf' [(pApp "Animal" [fApp "Tuna" []]),(pApp "Owns" [fApp "Curiosity" [],fApp (toSkolem 1) []])] [],fromList []),-                           (inf' [(pApp "Cat" [fApp "Tuna" []]),(pApp "Dog" [var "y"]),(pApp "Owns" [fApp "Curiosity" [],var "y"])] [],fromList []),-                           (inf' [(pApp "AnimalLover" [fApp "Curiosity" []])] [],fromList []),-                           (inf' [(pApp "Cat" [fApp "Tuna" []]),(pApp "Owns" [fApp "Curiosity" [],fApp (toSkolem 1) []])] [],fromList []),-                           (inf' [(pApp "Dog" [var "y"]),(pApp "Owns" [fApp "Curiosity" [],var "y"])] [],fromList []),-                           (inf' [(pApp "Owns" [fApp "Curiosity" [],fApp (toSkolem 1) []])] [],fromList [])]))-          ]-      }-    , TestProof-      { proofName = "prove curiosity kills tuna"-      , proofKnowledge = kbKnowledge (animalKB :: (String, [TestFormula formula term v p f]))-      , conjecture = kills [curiosity, tuna]-      , proofExpected =-          [ ChiouKB (S.fromList-                     [WithId {wiItem = inf' []                                 [(pApp "Dog" [fApp (toSkolem 1) []])],                 wiIdent = 1},-                      WithId {wiItem = inf' []                                 [(pApp "Owns" [fApp "Jack" [],fApp (toSkolem 1) []])], wiIdent = 1},-                      WithId {wiItem = inf' [(pApp "Dog" [var "y"]),-                                             (pApp "Owns" [var "x",var "y"])]  [(pApp "AnimalLover" [var "x"])],                      wiIdent = 2},-                      WithId {wiItem = inf' [(pApp "Animal" [var "y"]),-                                             (pApp "AnimalLover" [var "x"]),-                                             (pApp "Kills" [var "x",var "y"])] [], wiIdent = 3},-                      WithId {wiItem = inf' []                                 [(pApp "Kills" [fApp "Curiosity" [],fApp "Tuna" []]),-                                                                                (pApp "Kills" [fApp "Jack" [],fApp "Tuna" []])],      wiIdent = 4},-                      WithId {wiItem = inf' []                                 [(pApp "Cat" [fApp "Tuna" []])],                       wiIdent = 5},-                      WithId {wiItem = inf' [(pApp "Cat" [var "x"])]           [(pApp "Animal" [var "x"])],                           wiIdent = 6}])-          , ChiouResult (True,-                         S.fromList -                         [(makeINF' ([]) ([]),fromList []),-                          (makeINF' ([]) ([(pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])]),fromList []),-                          (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []])]) ([]),fromList []),-                          (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("AnimalLover") [fApp ("Jack") []])]) ([]),fromList []),-                          (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Dog") [var ("y")]),(pApp ("Owns") [fApp ("Jack") [],var ("y")])]) ([]),fromList []),-                          (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Dog") [fApp (toSkolem 1) []])]) ([]),fromList []),-                          (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem 1) []])]) ([]),fromList []),-                          (makeINF' ([(pApp ("AnimalLover") [fApp ("Jack") []])]) ([]),fromList []),-                          (makeINF' ([(pApp ("AnimalLover") [fApp ("Jack") []]),(pApp ("Cat") [fApp ("Tuna") []])]) ([]),fromList []),-                          (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []])]) ([]),fromList []),-                          (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Dog") [var ("y")]),(pApp ("Owns") [fApp ("Jack") [],var ("y")])]) ([]),fromList []),-                          (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Dog") [fApp (toSkolem 1) []])]) ([]),fromList []),-                          (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem 1) []])]) ([]),fromList []),-                          (makeINF' ([(pApp ("Dog") [var ("y")]),(pApp ("Owns") [fApp ("Jack") [],var ("y")])]) ([]),fromList []),-                          (makeINF' ([(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []])]) ([]),fromList [])])-          ]-      }-{--  -- Seems not to terminate-    , let (x, u, v, w, e) = (var "x", var "u", var "v", var "w", var "e") in-      TestProof-      { proofName = "chang example 4.3"-      , proofKnowledge = (fst chang43KB, map (convertFOF id id id . formula) (snd chang43KB))-      , conjecture = for_all' ["x"] (pApp "P" [x, x, e] .=>. (for_all' ["u", "v", "w"] (pApp "P" [u, v, w] .=>. pApp "P" [v, u, w])))-      , proofExpected =-          [ChiouResult (True, [])]-      }--}-    , let x = var "x" in-      TestProof-      { proofName = "socrates is mortal"-      , proofKnowledge = kbKnowledge (socratesKB :: (String, [TestFormula formula term v p f]))-      , conjecture = for_all "x" (socrates [x] .=>. mortal [x])-      , proofExpected = -         [ ChiouKB (S.fromList-                    [WithId {wiItem = inf' [(pApp "Human" [var "x"])] [(pApp "Mortal" [var "x"])], wiIdent = 1},-                     WithId {wiItem = inf' [(pApp "Socrates" [var "x"])] [(pApp "Human" [var "x"])], wiIdent = 2}])-         , ChiouResult (True,-                        S.fromList -                        [(makeINF' ([]) ([]),fromList []),-                         (makeINF' ([]) ([(pApp ("Human") [fApp (toSkolem 3) []])]),fromList []),-                         (makeINF' ([]) ([(pApp ("Mortal") [fApp (toSkolem 3) []])]),fromList []),-                         (makeINF' ([]) ([(pApp ("Socrates") [fApp (toSkolem 3) []])]),fromList []),-                         (makeINF' ([(pApp ("Mortal") [fApp (toSkolem 3) []])]) ([]),fromList [])])]-      }-    , let x = var "x" in-      TestProof-      { proofName = "socrates is not mortal"-      , proofKnowledge = kbKnowledge (socratesKB :: (String, [TestFormula formula term v p f]))-      , conjecture = (.~.) (for_all "x" (socrates [x] .=>. mortal [x]))-      , proofExpected = -         [ ChiouKB (S.fromList-                    [WithId {wiItem = inf' [(pApp "Human" [var "x"])] [(pApp "Mortal" [var "x"])], wiIdent = 1},-                     WithId {wiItem = inf' [(pApp "Socrates" [var "x"])] [(pApp "Human" [var "x"])], wiIdent = 2}])-         , ChiouResult (False-                       ,(S.fromList [(inf' [(pApp "Socrates" [var "x"])] [(pApp "Mortal" [var "x"])],fromList [("x",var "x")])]))]-      }-    , let x = var "x" in-      TestProof-      { proofName = "socrates exists and is not mortal"-      , proofKnowledge = kbKnowledge (socratesKB :: (String, [TestFormula formula term v p f]))-      , conjecture = (.~.) (exists "x" (socrates [x]) .&. for_all "x" (socrates [x] .=>. mortal [x]))-      , proofExpected = -         [ ChiouKB (S.fromList-                    [WithId {wiItem = inf' [(pApp "Human" [var "x"])] [(pApp "Mortal" [var "x"])], wiIdent = 1},-                     WithId {wiItem = inf' [(pApp "Socrates" [var "x"])] [(pApp "Human" [var "x"])], wiIdent = 2}])-         , ChiouResult (False,-                        S.fromList [(makeINF' ([]) ([(pApp ("Human") [fApp (toSkolem 3) []])]),fromList []),-                                    (makeINF' ([]) ([(pApp ("Mortal") [fApp (toSkolem 3) []])]),fromList []),-                                    (makeINF' ([]) ([(pApp ("Socrates") [fApp (toSkolem 3) []])]),fromList []),-                                    (makeINF' ([(pApp ("Socrates") [var ("x")])]) ([(pApp ("Mortal") [var ("x")])]),fromList [("x",var ("x"))])])-         ]-      }-    ]--inf' = makeINF'--toLL = map S.toList . S.toList-toSS = S.fromList . map S.fromList
− Test/Logic.hs 
@@ -1,436 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings,-             ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances #-}-{-# OPTIONS -Wall -Wwarn -fno-warn-name-shadowing -fno-warn-orphans #-}-module Test.Logic (tests) where--import Data.Logic.Classes.Arity (Arity(arity))-import Data.Logic.Classes.Boolean (Boolean(..))-import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), showFirstOrder, freeVars, substitute)-import Data.Logic.Classes.Literal (Literal)-import Data.Logic.Classes.Logic (Logic(..))-import Data.Logic.Classes.Negatable (Negatable(..))-import Data.Logic.Classes.Skolem (Skolem(..))-import Data.Logic.Classes.Term (Term(..))-import Data.Logic.Classes.Variable (Variable)-import Data.Logic.Classes.Pred (Pred(..), pApp)-import Data.Logic.Normal.Clause (clauseNormalForm)-import Data.Logic.Normal.Skolem (runNormal)-import Data.Logic.Satisfiable (theorem, inconsistant)-import Data.Logic.Test (V(..), AtomicFunction(..), Pr, TFormula, TTerm)-import qualified Data.Set as Set-import Data.String (IsString(fromString))-import PropLogic (PropForm(..), TruthTable, truthTable)-import qualified TextDisplay as TD-import Test.HUnit---- |Don't use this at home!  It breaks type safety, fromString "True"--- fromBool True.-instance Boolean String where-    fromBool = show--tests :: Test-tests = TestLabel "Logic" $ TestList (precTests ++ theoremTests)--formCase :: FirstOrderFormula TFormula TTerm V Pr AtomicFunction =>-            String -> TFormula -> TFormula -> Test-formCase s expected input = TestLabel s $ TestCase (assertEqual s expected input)--precTests :: [Test]-precTests =-    [ formCase "Logic - prec test 1"-               (a .&. (b .|. c))-               (a .&. b .|. c)-      -- You can't apply .~. without parens:-      -- :type (.~. a)   -> (FormulaPF -> t) -> t-      -- :type ((.~.) a) -> FormulaPF-    , formCase "Logic - prec test 2"-               (((.~.) a) .&. b)-               ((.~.) a .&. b)-    -- I switched the precedence of .&. and .|. from infixl to infixr to get-    -- some of the test cases to match the answers given on the miami.edu site,-    -- but maybe I should switch them back and adjust the answer given in the-    -- test case.-    , formCase "Logic - prec test 3"-               ((a .&. b) .&. c) -- infixl, with infixr we get (a .&. (b .&. c))-               (a .&. b .&. c)-    , TestCase (assertEqual "Logic - Find a free variable"-                (freeVars (for_all "x" (x .=. y) :: TFormula))-                (Set.singleton "y"))-    , TestCase (assertEqual "Logic - Substitute a variable"-                (map sub-                         [ for_all "x" (x .=. y) {- :: Formula String String -}-                         , for_all "y" (x .=. y) {- :: Formula String String -} ])-                [ for_all "x" (x .=. z) :: TFormula-                , for_all "y" (z .=. y) :: TFormula ])-    ]-    where-      sub f = substitute (head . Set.toList . freeVars $ f) (var "z") f-      a = pApp ("a") []-      b = pApp ("b") []-      c = pApp ("c") []--x :: TTerm-x = var (fromString "x")-y :: TTerm-y = var (fromString "y")-z :: TTerm-z = var (fromString "z")---- |Here is an example of automatic conversion from a FirstOrderFormula--- instance to a PropositionalFormula instance.  The result is PropForm--- a where a is the original type, but the a values will always be--- "atomic" formulas, never the operators which can be converted into--- the corresponding operator of a PropositionalFormula instance.-{--test9a :: Test-test9a = TestCase -           (assertEqual "Logic - convert to PropLogic"-            expected-            (flatten (cnf' (for_all "x" (for_all "y" (q [x, y] .<=>. for_all "z" (f [z, x] .<=>. f [z, y])))))))-    where-      f = pApp "f"-      q = pApp "q"-      expected :: PropForm TFormula-      expected = CJ [DJ [N (A (pApp ("q") [var (V "x"),var (V "y")])),-                         N (A (pApp ("f") [var (V "z"),var (V "x")])),-                         A (pApp ("f") [var (V "z"),var (V "y")])],-                     DJ [N (A (pApp ("q") [var (V "x"),var (V "y")])),-                         N (A (pApp ("f") [var (V "z"),var (V "y")])),-                         A (pApp ("f") [var (V "z"),var (V "x")])],-                     DJ [A (pApp ("f") [fApp (Skolem 1) [var (V "x"),var (V "y"),var (V "z")],var (V "x")]),-                         A (pApp ("f") [fApp (Skolem 1) [var (V "x"),var (V "y"),var (V "z")],var (V "y")]),-                         A (pApp ("q") [var (V "x"),var (V "y")])],-                     DJ [N (A (pApp ("f") [fApp (Skolem 1) [var (V "x"),var (V "y"),var (V "z")],var (V "y")])),-                         A (pApp ("f") [fApp (Skolem 1) [var (V "x"),var (V "y"),var (V "z")],var (V "y")]),-                         A (pApp ("q") [var (V "x"),var (V "y")])],-                     DJ [A (pApp ("f") [fApp (Skolem 1) [var (V "x"),var (V "y"),var (V "z")],var (V "x")]),-                         N (A (pApp ("f") [fApp (Skolem 1) [var (V "x"),var (V "y"),var (V "z")],var (V "x")])),-                         A (pApp ("q") [var (V "x"),var (V "y")])],-                     DJ [N (A (pApp ("f") [fApp (Skolem 1) [var (V "x"),var (V "y"),var (V "z")],var (V "y")])),-                         N (A (pApp ("f") [fApp (Skolem 1) [var (V "x"),var (V "y"),var (V "z")],var (V "x")])),-                         A (pApp ("q") [var (V "x"),var (V "y")])]]--moveQuantifiersOut1 :: Test-moveQuantifiersOut1 =-    formCase "Logic - moveQuantifiersOut1"-             (for_all "x2" ((pApp ("p") [var ("x2")]) .&. ((pApp ("q") [var ("x")]))))-             (prenexNormalForm (for_all "x" (pApp (fromString "p") [x]) .&. (pApp (fromString "q") [x])))--skolemize1 :: Test-skolemize1 =-    formCase "Logic - skolemize1" expected formula-    where-      expected :: TFormula-      expected = for_all [V "y",V "z"] (for_all [V "v"] (pApp "P" [fApp (toSkolem 1) [], y, z, fApp ((toSkolem 2)) [y, z], v, fApp (toSkolem 3) [y, z, v]]))-      formula :: TFormula-      formula = (snf' (exists ["x"] (for_all ["y", "z"] (exists ["u"] (for_all ["v"] (exists ["w"] (pApp "P" [x, y, z, u, v, w])))))))--skolemize2 :: Test-skolemize2 =-    formCase "Logic - skolemize2" expected formula-    where-      expected :: TFormula-      expected = for_all [V "y"] (pApp ("loves") [fApp (toSkolem 1) [],y])-      formula :: TFormula-      formula = snf' (exists ["x"] (for_all ["y"] (pApp "loves" [x, y])))--skolemize3 :: Test-skolemize3 =-    formCase "Logic - skolemize3" expected formula-    where-      expected :: TFormula-      expected = for_all [V "y"] (pApp ("loves") [fApp (toSkolem 1) [y],y])-      formula :: TFormula-      formula = snf' (for_all ["y"] (exists ["x"] (pApp "loves" [x, y])))--}-{--inf1 :: Test-inf1 =-    formCase "Logic - inf1" expected formula-    where-      expected :: TFormula-      expected = ((pApp ("p") [var ("x")]) .=>. (((pApp ("q") [var ("x")]) .|. ((pApp ("r") [var ("x")])))))-      formula :: {- ImplicativeNormalFormula inf (C.Sentence V String AtomicFunction) (C.Term V AtomicFunction) V String AtomicFunction => -} TFormula-      formula = convertFOF id id id (implicativeNormalForm (convertFOF id id id (for_all ["x"] (p [x] .=>. (q [x] .|. r [x]))) :: C.Sentence V String AtomicFunction) :: C.Sentence V String AtomicFunction)--}--instance Arity String where-    arity _ = Nothing--theoremTests :: [Test]-theoremTests =-    let s = pApp "S"-        h = pApp "H"-        m = pApp "M" in-    [ let formula = for_all "x" (((s [x] .=>. h [x]) .&. (h [x] .=>. m [x])) .=>.-                                  (s [x] .=>. m [x])) in-      TestCase (assertEqual "Logic - theorem test 1"-                (True,([],Just (CJ []),[([],True)]))-{--                (True,-                 ([(pApp ("H") [var (V "x")]),(pApp ("M") [var (V "x")]),(pApp ("S") [var (V "x")])],-                  Just (CJ [DJ [A (pApp ("S") [var (V "x")]),-                                A (pApp ("H") [var (V "x")]),-                                N (A (pApp ("S") [var (V "x")])),-                                A (pApp ("M") [var (V "x")])],-                            DJ [N (A (pApp ("H") [var (V "x")])),-                                A (pApp ("H") [var (V "x")]),-                                N (A (pApp ("S") [var (V "x")])),-                                A (pApp ("M") [var (V "x")])],-                            DJ [A (pApp ("S") [var (V "x")]),-                                N (A (pApp ("M") [var (V "x")])),-                                N (A (pApp ("S") [var (V "x")])),-                                A (pApp ("M") [var (V "x")])],-                            DJ [N (A (pApp ("H") [var (V "x")])),-                                N (A (pApp ("M") [var (V "x")])),-                                N (A (pApp ("S") [var (V "x")])),-                                A (pApp ("M") [var (V "x")])]]),-                  [([False,False,False],True),-                   ([False,False,True],True),-                   ([False,True,False],True),-                   ([False,True,True],True),-                   ([True,False,False],True),-                   ([True,False,True],True),-                   ([True,True,False],True),-                   ([True,True,True],True)]))--}-                (runNormal (theorem formula), table formula))-    , TestCase (assertEqual "Logic - theorem test 1a"-                (False,-                 False,-                 ([(pApp1 ("H") (fApp (toSkolem 1) [])),-                   (pApp1 ("M") (var ("y"))),-                   (pApp1 ("M") (fApp (toSkolem 1) [])),-                   (pApp1 ("S") (var ("y"))),-                   (pApp1 ("S") (fApp (toSkolem 1) []))],-                  Just (CJ [DJ [A (pApp1 ("H") (fApp (toSkolem 1) [])),-                                A (pApp1 ("M") (var ("y"))),-                                A (pApp1 ("S") (fApp (toSkolem 1) [])),-                                N (A (pApp1 ("S") (var ("y"))))],-                            DJ [A (pApp1 ("M") (var ("y"))),-                                A (pApp1 ("S") (fApp (toSkolem 1) [])),-                                N (A (pApp1 ("M") (fApp (toSkolem 1) []))),-                                N (A (pApp1 ("S") (var ("y"))))],-                            DJ [A (pApp1 ("M") (var ("y"))),-                                N (A (pApp1 ("H") (fApp (toSkolem 1) []))),-                                N (A (pApp1 ("M") (fApp (toSkolem 1) []))),-                                N (A (pApp1 ("S") (var ("y"))))]]),-                  [([False,False,False,False,False],True),-                   ([False,False,False,False,True],True),-                   ([False,False,False,True,False],False),-                   ([False,False,False,True,True],True),-                   ([False,False,True,False,False],True),-                   ([False,False,True,False,True],True),-                   ([False,False,True,True,False],False),-                   ([False,False,True,True,True],True),-                   ([False,True,False,False,False],True),-                   ([False,True,False,False,True],True),-                   ([False,True,False,True,False],True),-                   ([False,True,False,True,True],True),-                   ([False,True,True,False,False],True),-                   ([False,True,True,False,True],True),-                   ([False,True,True,True,False],True),-                   ([False,True,True,True,True],True),-                   ([True,False,False,False,False],True),-                   ([True,False,False,False,True],True),-                   ([True,False,False,True,False],True),-                   ([True,False,False,True,True],True),-                   ([True,False,True,False,False],True),-                   ([True,False,True,False,True],True),-                   ([True,False,True,True,False],False),-                   ([True,False,True,True,True],False),-                   ([True,True,False,False,False],True),-                   ([True,True,False,False,True],True),-                   ([True,True,False,True,False],True),-                   ([True,True,False,True,True],True),-                   ([True,True,True,False,False],True),-                   ([True,True,True,False,True],True),-                   ([True,True,True,True,False],True),-                   ([True,True,True,True,True],True)]))-                -                (let formula = (for_all "x" ((s [x] .=>. h [x]) .&. (h [x] .=>. m [x]))) .=>.-                               (for_all "y" (s [y] .=>. m [y])) in-                 (runNormal (theorem formula), runNormal (inconsistant formula), table formula)))-                -    , TestCase (assertEqual "Logic - socrates is mortal, truth table"-                ([(pApp1 ("H") (var ("x"))),-                  (pApp1 ("M") (var ("x"))),-                  (pApp1 ("S") (var ("x")))],-                 Just (CJ [DJ [A (pApp1 ("H") (var ("x"))),N (A (pApp1 ("S") (var ("x"))))],-                           DJ [A (pApp1 ("M") (var ("x"))),N (A (pApp1 ("H") (var ("x"))))],-                           DJ [A (pApp1 ("M") (var ("x"))),N (A (pApp1 ("S") (var ("x"))))]]),-                 [([False,False,False],True),-                  ([False,False,True],False),-                  ([False,True,False],True),-                  ([False,True,True],False),-                  ([True,False,False],False),-                  ([True,False,True],False),-                  ([True,True,False],True),-                  ([True,True,True],True)])-                -- This formula has separate variables for each of the-                -- three beliefs.  To combine these into an argument-                -- we would wrap a single exists around them all and-                -- remove the existing ones, substituting that one-                -- variable into each formula.-                (table (for_all "x" (s [x] .=>. h [x]) .&.-                         for_all "y" (h [y] .=>. m [y]) .&.-                         for_all "z" (s [z] .=>. m [z]))))--    , TestCase (assertEqual "Logic - socrates is not mortal"-                (False,-                 False,-                 ([(pApp ("H") [var ("x")]),-                   (pApp ("M") [var ("x")]),-                   (pApp ("S") [var ("x")]),-                   (pApp ("S") [fApp ("socrates") []])],-                  Just (CJ [DJ [A (pApp ("H") [var ("x")]),N (A (pApp ("S") [var ("x")]))],-                            DJ [A (pApp ("M") [var ("x")]),N (A (pApp ("H") [var ("x")]))],-                            DJ [A (pApp ("S") [fApp ("socrates") []])],-                            DJ [N (A (pApp ("M") [var ("x")])),N (A (pApp ("S") [var ("x")]))]]),-                  [([False,False,False,False],False),-                   ([False,False,False,True],True),-                   ([False,False,True,False],False),-                   ([False,False,True,True],False),-                   ([False,True,False,False],False),-                   ([False,True,False,True],True),-                   ([False,True,True,False],False),-                   ([False,True,True,True],False),-                   ([True,False,False,False],False),-                   ([True,False,False,True],False),-                   ([True,False,True,False],False),-                   ([True,False,True,True],False),-                   ([True,True,False,False],False),-                   ([True,True,False,True],True),-                   ([True,True,True,False],False),-                   ([True,True,True,True],False)]),-                 toSS [[(pApp ("H") [var ("x")]),((.~.) (pApp ("S") [var ("x")]))],-                       [(pApp ("M") [var ("x")]),((.~.) (pApp ("H") [var ("x")]))],-                       [(pApp ("S") [fApp ("socrates") []])],-                       [((.~.) (pApp ("M") [var ("x")])),((.~.) (pApp ("S") [var ("x")]))]])-                -- This represents a list of beliefs like those in our-                -- database: socrates is a man, all men are mortal,-                -- each with its own quantified variable.  In-                -- addition, we have an inconsistant belief, socrates-                -- is not mortal.  If we had a single variable this-                -- would be inconsistant, but as it stands it is an-                -- invalid argument, there are both 0 and 1 lines in-                -- the truth table.  If we go through the table and-                -- eliminate the lines where S(SkZ(x,y)) is true but M(SkZ(x,y)) is-                -- false (for any x) and those where H(x) is true but-                -- M(x) is false, the remaining lines would all be zero,-                -- the argument would be inconsistant (an anti-theorem.)-                -- How can we modify the formula to make these lines 0?-                (let (formula :: TFormula) =-                         for_all "x" ((s [x] .=>. h [x]) .&.-                                      (h [x] .=>. m [x]) .&.-                                      (m [x] .=>. ((.~.) (s [x])))) .&.-                         (s [fApp "socrates" []]) in-                 (runNormal (theorem formula), runNormal (inconsistant formula), table formula, runNormal (clauseNormalForm formula) :: Set.Set (Set.Set TFormula))))-    , let (formula :: TFormula) =-              (for_all "x" (pApp "L" [var "x"] .=>. pApp "F" [var "x"]) .&. -- All logicians are funny-               exists "x" (pApp "L" [var "x"])) .=>.                            -- Someone is a logician-              (.~.) (exists "x" (pApp "F" [var "x"]))                           -- Someone / Nobody is funny-          input = table formula-          expected = ([(pApp ("F") [var ("x2")]),-                       (pApp ("F") [fApp (toSkolem 1) []]),-                       (pApp ("L") [var ("x")]),-                       (pApp ("L") [fApp (toSkolem 1) []])],-                      Just (CJ [DJ [A (pApp1 ("L") (fApp (toSkolem 1) [])),N (A (pApp1 ("F") (var ("x2")))),N (A (pApp1 ("L") (var ("x"))))],-                                DJ [N (A (pApp1 ("F") (var ("x2")))),N (A (pApp1 ("F") (fApp (toSkolem 1) []))),N (A (pApp1 ("L") (var ("x"))))]]),-                      [([False,False,False,False],True),-                       ([False,False,False,True],True),-                       ([False,False,True,False],True),-                       ([False,False,True,True],True),-                       ([False,True,False,False],True),-                       ([False,True,False,True],True),-                       ([False,True,True,False],True),-                       ([False,True,True,True],True),-                       ([True,False,False,False],True),-                       ([True,False,False,True],True),-                       ([True,False,True,False],False),-                       ([True,False,True,True],True),-                       ([True,True,False,False],True),-                       ([True,True,False,True],True),-                       ([True,True,True,False],False),-                       ([True,True,True,True],False)])-      in TestCase (assertEqual "Logic - gensler189" expected input)-    , let (formula :: TFormula) =-              (for_all "x" (pApp "L" [var "x"] .=>. pApp "F" [var "x"]) .&. -- All logicians are funny-               exists "y" (pApp "L" [var (fromString "y")])) .=>.           -- Someone is a logician-              (.~.) (exists "z" (pApp "F" [var "z"]))                       -- Someone / Nobody is funny-          input = table formula-          expected :: TruthTable TFormula-          expected = ([(pApp1 ("F") (var ("z"))),(pApp1 ("F") (fApp (toSkolem 1) [])),(pApp1 ("L") (var ("y"))),(pApp1 ("L") (fApp (toSkolem 1) []))],Just (CJ [DJ [A (pApp1 ("L") (fApp (toSkolem 1) [])),N (A (pApp1 ("F") (var ("z")))),N (A (pApp1 ("L") (var ("y"))))],DJ [N (A (pApp1 ("F") (var ("z")))),N (A (pApp1 ("F") (fApp (toSkolem 1) []))),N (A (pApp1 ("L") (var ("y"))))]]),[([False,False,False,False],True),([False,False,False,True],True),([False,False,True,False],True),([False,False,True,True],True),([False,True,False,False],True),([False,True,False,True],True),([False,True,True,False],True),([False,True,True,True],True),([True,False,False,False],True),([True,False,False,True],True),([True,False,True,False],False),([True,False,True,True],True),([True,True,False,False],True),([True,True,False,True],True),([True,True,True,False],False),([True,True,True,True],False)])-      in TestCase (assertEqual "Logic - gensler189 renamed" expected input)-    ]--toSS :: Ord a => [[a]] -> Set.Set (Set.Set a)-toSS = Set.fromList . map Set.fromList--{--theorem5 =-    TestCase (assertEqual "Logic - theorm test 2"-              (Just True)-              (theorem ((.~.) ((for_all "x" (((s [x] .=>. h [x]) .&.-                                               (h [x] .=>. m [x]))) .&.-                                exists "x" (s [x] .&.-                                             ((.~.) (m [x]))))))))--}--instance TD.Display TFormula where-    textFrame x = [showFirstOrder x]-{--    textFrame x = [quickShow x]-        where-          quickShow =-              foldF (\ _ -> error "Expecting atoms")-                    (\ _ _ _ -> error "Expecting atoms")-                    (\ _ _ _ -> error "Expecting atoms")-                    (\ t1 op t2 -> quickShowTerm t1 ++ quickShowOp op ++ quickShowTerm t2)-                    (\ p ts -> quickShowPred p ++ "(" ++ intercalate "," (map quickShowTerm ts) ++ ")")-          quickShowTerm =-              foldT quickShowVar-                    (\ f ts -> quickShowFn f ++ "(" ++ intercalate "," (map quickShowTerm ts) ++ ")")-          quickShowVar v = show v-          quickShowPred s = s-          quickShowFn (AtomicFunction s) = s-          quickShowOp (:=:) = "="-          quickShowOp (:!=:) = "!="--}--{---- Truth table tests, find a more reasonable result value than [String].--(theorem1a, theorem1b, theorem1c, theorem1d) =-    ( TestCase (assertEqual "Logic - truth table 1"-                (Just ["foo"])-                (prepare (for_all "x" (((s [x] .=>. h [x]) .&. (h [x] .=>. m [x])) .=>. (s [x] .=>. m [x]))) >>=-                 return . TD.textFrame . truthTable)) )-    where s = pApp "S"-          h = pApp "H"-          m = pApp "M"--type FormulaPF = Formula String String-type F = PropForm FormulaPF--prepare :: FormulaPF -> F-prepare formula = ({- flatten . -} fromJust . toPropositional convertA . cnf . (.~.) $ formula)--convertA = Just . A--}--table :: forall formula term v p f. (FirstOrderFormula formula term v p f, Literal formula term v p f,-                                     Ord formula, Skolem f, IsString v, Variable v, TD.Display formula) =>-         formula -> TruthTable formula-table f =-    -- truthTable :: Ord a => PropForm a -> TruthTable a-    tt cnf'-    where-      tt :: PropForm formula -> TruthTable formula-      tt = truthTable-      cnf' :: PropForm formula-      cnf' = CJ (map (DJ . map n) cnf)-      cnf :: [[formula]]-      cnf = fromSS (runNormal (clauseNormalForm f))-      fromSS = map Set.toList . Set.toList-      n f = (if negated f then N . A . (.~.) else A) $ f
− Test/TPTP.hs 
@@ -1,22 +0,0 @@-module Test.TPTP where-    -import Codec.TPTP (Formula)-import Data.Logic.FirstOrder (conj)-import Data.Logic.Instances.TPTP-import Data.Logic.Monad (runNormal)-import Data.Logic.Logic (Logic ((.~.), (.=>.)))-import Data.Logic.Normal (cnfTrace)-import Data.Logic.Test (TestFormula(formula))-import Test.Data (chang43KB, chang43Conjecture)-import Test.HUnit--tests :: Test-tests = TestLabel "TPTP" $ TestList [tptp]--tptp :: Test-tptp =-    TestCase (assertEqual "tptp cnf trace" "abc" (runNormal (cnfTrace f)))-    where-      f :: Formula-      f = (.~.) (conj (map formula (snd (chang43KB :: (String, [TestFormula Formula])))) .=>.-                 formula chang43Conjecture)
− Test/Test.hs 
@@ -1,22 +0,0 @@-import Data.Logic.Classes.FirstOrder (showFirstOrder)-import Data.Logic.Test (TestFormula, TestProof, V, Pr, AtomicFunction, TFormula, TTerm)-import Data.Logic.Types.FirstOrder-import System.Exit-import Test.HUnit-import qualified Test.Logic as Logic-import qualified Test.Chiou0 as Chiou0---import qualified Test.TPTP as TPTP-import qualified Test.Data as 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 :: [TestFormula TFormula TTerm V Pr AtomicFunction])-      proofs = (Data.proofs :: [TestProof TFormula TTerm V])
logic-classes.cabal view
@@ -1,5 +1,5 @@ Name:             logic-classes-Version:          0.48+Version:          1.1 License:          BSD3 Author:           David Fox <dsf@seereason.com> Maintainer:       SeeReason Partners <partners@seereason.com>@@ -15,38 +15,66 @@  Library  GHC-options: -Wall -O2- Exposed-Modules:  Data.Logic-                   Data.Logic.Classes.Arity-                   Data.Logic.Classes.Boolean+ Exposed-Modules:  Data.Logic.Classes.Arity+                   Data.Logic.Classes.Apply                    Data.Logic.Classes.ClauseNormalForm+                   Data.Logic.Classes.Combine+                   Data.Logic.Classes.Constants+                   Data.Logic.Classes.Equals                    Data.Logic.Classes.FirstOrder                    Data.Logic.Classes.Literal-                   Data.Logic.Classes.Logic-                   Data.Logic.Classes.Negatable-                   Data.Logic.Classes.Pred+                   Data.Logic.Classes.Negate                    Data.Logic.Classes.Propositional                    Data.Logic.Classes.Skolem                    Data.Logic.Classes.Term                    Data.Logic.Classes.Variable+                   Data.Logic.Harrison.Equal+                   Data.Logic.Harrison.FOL+                   Data.Logic.Harrison.Formulas.FirstOrder+                   Data.Logic.Harrison.Formulas.Propositional+                   Data.Logic.Harrison.Lib+                   Data.Logic.Harrison.Meson+                   Data.Logic.Harrison.Normal+                   Data.Logic.Harrison.Prolog+                   Data.Logic.Harrison.Prop+                   Data.Logic.Harrison.Resolution+                   Data.Logic.Harrison.Skolem+                   Data.Logic.Harrison.Tableaux+                   Data.Logic.Harrison.Unif                    Data.Logic.Instances.Chiou                    Data.Logic.Instances.PropLogic                    Data.Logic.Instances.SatSolver                    Data.Logic.KnowledgeBase                    Data.Logic.Normal.Clause                    Data.Logic.Normal.Implicative-                   Data.Logic.Normal.Negation-                   Data.Logic.Normal.Prenex-                   Data.Logic.Normal.Skolem                    Data.Logic.Resolution                    Data.Logic.Satisfiable                    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- Other-Modules:    Data.Logic.Test- Build-Depends:    base >= 4.3 && < 5, containers, fgl, happstack-data, incremental-sat-solver,+ Build-Depends:    applicative-extras, base >= 4.3 && < 5, containers, fgl, happstack-data, incremental-sat-solver,                    mtl, syb-with-class, text, PropLogic, pretty, safecopy, set-extra, syb  Executable tests- Main-Is: Test/Test.hs+ GHC-Options: -Wall -O2+ Main-Is: Data/Logic/Tests/Main.hs  Build-Depends: HUnit- Other-Modules:    Test.Chiou0 Test.Data Test.Logic, Test.TPTP+ Other-Modules:    Data.Logic.Tests.Chiou0+                   Data.Logic.Tests.Common+                   Data.Logic.Tests.Data+                   Data.Logic.Tests.Logic+                   Data.Logic.Tests.TPTP+                   Data.Logic.Tests.Harrison.Equal+                   Data.Logic.Tests.Harrison.FOL+                   Data.Logic.Tests.Harrison.HUnit+                   Data.Logic.Tests.Harrison.Meson+                   Data.Logic.Tests.Harrison.Prop+                   Data.Logic.Tests.Harrison.Resolution+                   Data.Logic.Tests.Harrison.Skolem+                   Data.Logic.Tests.Harrison.Main+                   Data.Logic.Tests.Harrison.Unif