packages feed

logic-classes 1.1 → 1.4

raw patch · 61 files changed

+3559/−1289 lines, 61 filesdep +template-haskell

Dependencies added: template-haskell

Files

Data/Logic/Classes/Apply.hs view
@@ -3,6 +3,7 @@ -- | The Apply class represents a type of atom the only supports predicate application. module Data.Logic.Classes.Apply     ( Apply(..)+    , Predicate     , apply     , zipApplys     , apply0, apply1, apply2, apply3, apply4, apply5, apply6, apply7@@ -12,16 +13,20 @@     , substApply     ) where +import Data.Data (Data) import Data.Logic.Classes.Arity import Data.Logic.Classes.Constants+import Data.Logic.Classes.Pretty (Pretty) import Data.Logic.Classes.Term (Term, showTerm, prettyTerm, fvt, tsubst) import Data.List (intercalate, intersperse) import Data.Maybe (fromMaybe) import qualified Data.Map as Map import qualified Data.Set as Set-import Text.PrettyPrint (Doc, (<>), text, empty, parens, hcat)+import Text.PrettyPrint (Doc, (<>), text, empty, parens, cat) -class (Arity p, Constants p, Eq p) => Apply atom p term | atom -> p term where+class (Arity p, Constants p, Eq p, Ord p, Data p, Pretty p) => Predicate p++class Predicate p => Apply atom p term | atom -> p term where     foldApply :: (p -> [term] -> r) -> (Bool -> r) -> atom -> r     apply' :: p -> [term] -> atom @@ -61,7 +66,7 @@     foldApply (\ p ts ->                    pp p <> case ts of                              [] -> empty-                             _ -> parens (hcat (intersperse (text ",") (map (prettyTerm pv pf) ts))))+                             _ -> parens (cat (intersperse (text ",") (map (prettyTerm pv pf) ts))))               (\ x -> text (if x then "true" else "false"))               atom
+ Data/Logic/Classes/Atom.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses, TypeFamilies #-}+-- | Substitution and finding variables are two basic operations on+-- formulas that contain terms and variables.  If a formula type+-- supports quantifiers we can also find free variables, otherwise all+-- variables are considered free.+module Data.Logic.Classes.Atom+    ( Atom(..)+    -- , Formula(..)+    ) where++import Control.Applicative.Error (Failing)+import qualified Data.Map as Map+import qualified Data.Set as Set++{-+class Formula formula term v | formula -> term v where+    substitute :: Map.Map v term -> formula -> formula+    allVariables :: formula -> Set.Set v+    freeVariables :: formula -> Set.Set v+    unify :: Map.Map v term -> formula -> formula -> Failing (Map.Map v term)+    match :: Map.Map v term -> formula -> formula -> Failing (Map.Map v term)+    -- ^ Very similar to unify, not quite sure if there is a difference+    foldTerms :: (term -> r -> r) -> r -> formula -> r+    isRename :: formula -> formula -> Bool+    getSubst :: Map.Map v term -> formula -> Map.Map v term+-}++class Atom atom term v | atom -> term v where+    substitute :: Map.Map v term -> atom -> atom+    allVariables :: atom -> Set.Set v+    freeVariables :: atom -> Set.Set v+    unify :: Map.Map v term -> atom -> atom -> Failing (Map.Map v term)+    match :: Map.Map v term -> atom -> atom -> Failing (Map.Map v term)+    -- ^ Very similar to unify, not quite sure if there is a difference+    foldTerms :: (term -> r -> r) -> r -> atom -> r+    isRename :: atom -> atom -> Bool+    getSubst :: Map.Map v term -> atom -> Map.Map v term+
Data/Logic/Classes/Combine.hs view
@@ -16,10 +16,13 @@     -- * Use in Harrison's code     , (==>)     , (<=>)+    , prettyBinOp     ) where  import Data.Generics (Data, Typeable) import Data.Logic.Classes.Negate (Negatable, (.~.))+import Data.Logic.Classes.Pretty (Pretty(pretty))+import Text.PrettyPrint (Doc, text)  -- | A type class for logical formulas.  Minimal implementation: -- @@@ -54,12 +57,9 @@     (.~&.) :: 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 1  .<=>. ,  .<~>., ⇔, <=>+infixr 2  .=>., ⇒, ==>+infixr 3  .|., ∨ infixl 4  .&., ∧  -- |'Combination' is a helper type used in the signatures of the@@ -69,7 +69,7 @@ data Combination formula     = BinOp formula BinOp formula     | (:~:) formula-    deriving (Eq,Ord,Data,Typeable,Show)+    deriving (Eq, Ord, Data, Typeable, Show, Read)  -- | A helper function for building folds: -- @@@ -90,7 +90,7 @@     |  (:=>:)  -- ^ Implication     |  (:&:)  -- ^ AND     |  (:|:)  -- ^ OR-    deriving (Eq,Ord,Data,Typeable,Enum,Bounded,Show)+    deriving (Eq, Ord, Data, Typeable, Enum, Bounded, Show, Read)  binop :: Combinable formula => formula -> BinOp -> formula -> formula binop a (:&:) b = a .&. b@@ -112,3 +112,12 @@ (==>) = (.=>.) (<=>) :: Combinable formula => formula -> formula -> formula (<=>) = (.<=>.)++prettyBinOp :: BinOp -> Doc+prettyBinOp (:<=>:) = text "⇔"+prettyBinOp (:=>:) = text "⇒"+prettyBinOp (:&:) = text "∧"+prettyBinOp (:|:) = text "∨"++instance Pretty BinOp where+    pretty = prettyBinOp
Data/Logic/Classes/Constants.hs view
@@ -1,25 +1,28 @@ module Data.Logic.Classes.Constants-    ( Constants(..)-    , asBool+    ( Constants(asBool, fromBool)     , ifElse+    , true     , (⊨)+    , false     , (⊭)+    , prettyBool     ) where +import Data.Logic.Classes.Pretty (Pretty(pretty))+import Text.PrettyPrint (Doc, text)+ -- |Some types in the Logic class heirarchy need to have True and -- False elements. class Constants p where+    asBool :: p -> Maybe Bool     fromBool :: Bool -> p-    true :: 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+true :: Constants p => p+true = fromBool True +false :: Constants p => p+false = fromBool False+ ifElse :: a -> a -> Bool -> a ifElse t _ True = t ifElse _ f False = f@@ -28,3 +31,10 @@ (⊨) = true (⊭) :: Constants formula => formula (⊭) = false++prettyBool :: Bool -> Doc+prettyBool True = text "⊨"+prettyBool False = text "⊭"++instance Pretty Bool where+    pretty = prettyBool
Data/Logic/Classes/Equals.hs view
@@ -19,11 +19,14 @@     ) where  import Data.List (intercalate, intersperse)+import Data.Logic.Classes.Apply (Predicate) import Data.Logic.Classes.Arity (Arity(..)) import Data.Logic.Classes.Combine (Combination(..), BinOp(..)) import Data.Logic.Classes.Constants (Constants(fromBool), ifElse) import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), Quant(..))+import Data.Logic.Classes.Formula (Formula(atomic)) import Data.Logic.Classes.Negate ((.~.))+import Data.Logic.Classes.Pretty (Pretty(pretty)) import Data.Logic.Classes.Term (Term, convertTerm, showTerm, prettyTerm, fvt, tsubst, funcs) import qualified Data.Map as Map import Data.Maybe (fromMaybe)@@ -31,7 +34,7 @@ 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+class Predicate 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@@ -46,8 +49,12 @@ -- | 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)+data Ord p => PredicateName p = Named p Int | Equals deriving (Eq, Ord, Show) +instance (Pretty p, Ord p) => Pretty (PredicateName p) where+    pretty Equals = text "="+    pretty (Named p _) = pretty p+ zipAtomsEq :: AtomEq atom p term =>               (p -> [term] -> p -> [term] -> Maybe r)            -> (Bool -> Bool -> Maybe r)@@ -77,15 +84,17 @@ 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)+arityError :: (Arity p) => p -> [a] -> t+arityError _p _ts = error "arity error"+-- arityError :: (Arity p, Pretty p) => p -> [a] -> t+-- arityError p ts = error $ "arity error: " ++ show (length ts) ++ " arguments applied to arity " ++ show (arity p) ++ " predicate " ++ show (pretty p)  pApp :: (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> [term] -> formula pApp p ts = atomic (applyEq p ts)  -- | Versions of pApp specialized for different argument counts.-pApp0 :: (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> formula-pApp0 p = atomic (apply0 p)+pApp0 :: forall formula atom term v p. (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> formula+pApp0 p = atomic (apply0 p :: atom) pApp1 :: (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> term -> formula pApp1 p a = atomic (apply1 p a) pApp2 :: (FirstOrderFormula formula atom v, AtomEq atom p term) => p -> term -> term -> formula@@ -161,7 +170,7 @@     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 :: forall atom term v p f. (AtomEq atom p term, Term term v f, Show v, Show p, Show f) => atom -> String showAtomEq =     foldAtomEq (\ p ts -> "(pApp" ++ show (length ts) ++ " (" ++ show p ++ ") (" ++ intercalate ") (" (map showTerm ts) ++ "))")                (\ x -> if x then "true" else "false")
Data/Logic/Classes/FirstOrder.hs view
@@ -26,25 +26,24 @@     , withUnivQuants     , showFirstOrder     , prettyFirstOrder-{--    , freeVars-    , quantVars-    , allVars-    , univquant_free_vars-    , substitute-    , substitutePairs-    , disj-    , conj--}+    , fixityFirstOrder+    , foldAtomsFirstOrder+    , mapAtomsFirstOrder+    , onatoms+    , overatoms+    , atom_union     ) where  import Data.Generics (Data, Typeable) 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.Formula (Formula(atomic))+import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), Fixity(..), FixityDirection(..))+import qualified Data.Logic.Classes.Propositional as P import Data.Logic.Classes.Variable (Variable) import Data.SafeCopy (base, deriveSafeCopy)+import qualified Data.Set as Set import Happstack.Data (deriveNewData) import Text.PrettyPrint (Doc, (<>), (<+>), text, parens, nest) @@ -53,13 +52,15 @@ -- functional dependencies are necessary here so we can write -- functions that don't fix all of the type parameters.  For example, -- without them the univquant_free_vars function gives the error @No--- instance for (FirstOrderFormula Formula term V p f)@ because the+-- instance for (FirstOrderFormula Formula atom V)@ because the -- function doesn't mention the Term type.-class ( Combinable formula  -- Basic logic operations+class ( Formula formula atom+      , Combinable formula  -- Basic logic operations       , Constants formula       , Constants atom+      , HasFixity atom       , Variable v-      , Show v+      , Pretty atom, Pretty v       ) => FirstOrderFormula formula atom v | formula -> atom v where     -- | Universal quantification - for all x (formula x)     for_all :: v -> formula -> formula@@ -76,7 +77,6 @@                    -> (atom -> r)                    -> formula                    -> r-    atomic :: atom -> formula  zipFirstOrder :: FirstOrderFormula formula atom v =>                  (Quant -> v -> formula -> Quant -> v -> formula -> Maybe r)@@ -98,26 +98,26 @@ -- 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)+pApp :: forall formula atom term v p. (FirstOrderFormula formula atom v, Apply atom p term) => p -> [term] -> formula+pApp p ts = atomic (apply p ts :: atom)  -- | 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)+pApp0 :: forall formula atom term v p. (FirstOrderFormula formula atom v, Apply atom p term) => p -> formula+pApp0 p = atomic (apply0 p :: atom)+pApp1 :: forall formula atom term v p. (FirstOrderFormula formula atom v, Apply atom p term) => p -> term -> formula+pApp1 p a = atomic (apply1 p a :: atom)+pApp2 :: forall formula atom term v p. (FirstOrderFormula formula atom v, Apply atom p term) => p -> term -> term -> formula+pApp2 p a b = atomic (apply2 p a b :: atom)+pApp3 :: forall formula atom term v p. (FirstOrderFormula formula atom v, Apply atom p term) => p -> term -> term -> term -> formula+pApp3 p a b c = atomic (apply3 p a b c :: atom)+pApp4 :: forall formula atom term v p. (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 :: atom)+pApp5 :: forall formula atom term v p. (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 :: atom)+pApp6 :: forall formula atom term v p. (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 :: atom)+pApp7 :: forall formula atom term v p. (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 :: atom)  -- |for_all with a list of variables, for backwards compatibility. for_all' :: FirstOrderFormula formula atom v => [v] -> formula -> formula@@ -134,7 +134,8 @@ (?) :: FirstOrderFormula formula atom v => v -> formula -> formula (?) = exists -infix 1 !, ?, ∀, ∃+-- Irrelevant, because these are always used as prefix operators, never as infix.+infixr 9 !, ?, ∀, ∃  -- | ∀ can't be a function when -XUnicodeSyntax is enabled. (∀) :: FirstOrderFormula formula atom v => v -> formula -> formula@@ -172,8 +173,8 @@ -- into an atom that it is unable to convert. toPropositional :: forall formula1 atom v formula2 atom2.                    (FirstOrderFormula formula1 atom v,-                    PropositionalFormula formula2 atom2) =>-                   (formula1 -> formula2) -> formula1 -> formula2+                    P.PropositionalFormula formula2 atom2) =>+                   (atom -> atom2) -> formula1 -> formula2 toPropositional convertAtom formula =     foldFirstOrder qu co tf at formula     where@@ -182,10 +183,10 @@       co (BinOp f1 op f2) = combine (BinOp (convert' f1) op (convert' f2))       co ((:~:) f) = combine ((:~:) (convert' f))       tf = fromBool-      at _ = convertAtom formula+      at = atomic . convertAtom  -- | Display a formula in a format that can be read into the interpreter.-showFirstOrder :: forall formula atom v. (FirstOrderFormula formula atom v) => (atom -> String) -> formula -> String+showFirstOrder :: forall formula atom v. (FirstOrderFormula formula atom v, Show v) => (atom -> String) -> formula -> String showFirstOrder sa formula =     foldFirstOrder qu co tf at formula     where@@ -204,31 +205,42 @@  prettyFirstOrder :: forall formula atom v. (FirstOrderFormula formula atom v) =>                       (Int -> atom -> Doc) -> (v -> Doc) -> Int -> formula -> Doc-prettyFirstOrder pa pv prec formula =+prettyFirstOrder pa pv pprec formula =+    parensIf (pprec > prec) $     foldFirstOrder-          (\ qop v f -> parensIf (prec > 1) $ prettyQuant qop <> pv v <+> prettyFirstOrder pa pv 1 f)+          (\ qop v f -> prettyQuant qop <> pv v <> text "." <+> (prettyFirstOrder pa pv prec f))           (\ cm ->                case cm of                  (BinOp f1 op f2) ->                      case op of-                       (:=>:) -> 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)+                       (:=>:) -> (prettyFirstOrder pa pv 2 f1 <+> pretty op <+> prettyFirstOrder pa pv prec f2)+                       (:<=>:) -> (prettyFirstOrder pa pv 2 f1 <+> pretty op <+> prettyFirstOrder pa pv prec f2)+                       (:&:) -> (prettyFirstOrder pa pv 3 f1 <+> pretty op <+> prettyFirstOrder pa pv prec f2)+                       (:|:) -> (prettyFirstOrder pa pv 4 f1 <+> pretty op <+> prettyFirstOrder pa pv prec f2)+                 ((:~:) f) -> text "¬" {-"~"-} <> prettyFirstOrder pa pv prec f)           (text . ifElse "true" "false")-          (pa 6)+          (pa prec)           formula     where+      Fixity prec _ = fixityFirstOrder formula       parensIf False = id       parensIf _ = parens . nest 1-      prettyQuant Forall = text {-"∀"-} "!"-      prettyQuant Exists = text {-"∃"-} "?"-      formOp (:<=>:) = text "<=>"-      formOp (:=>:) = text "=>"-      formOp (:&:) = text "&"-      formOp (:|:) = text "|"+      prettyQuant Forall = text "∀" -- "!"+      prettyQuant Exists = text "∃" -- "?" +fixityFirstOrder :: (HasFixity atom, FirstOrderFormula formula atom v) => formula -> Fixity+fixityFirstOrder formula =+    foldFirstOrder qu co tf at formula+    where+      qu _ _ _ = Fixity 10 InfixN+      co ((:~:) _) = Fixity 5 InfixN+      co (BinOp _ (:&:) _) = Fixity 4 InfixL+      co (BinOp _ (:|:) _) = Fixity 3 InfixL+      co (BinOp _ (:=>:) _) = Fixity 2 InfixR+      co (BinOp _ (:<=>:) _) = Fixity 1 InfixL+      tf _ = Fixity 10 InfixN+      at = fixity+ -- | Examine the formula to find the list of outermost universally -- quantified variables, and call a function with that list and the -- formula after the quantifiers are removed.@@ -245,6 +257,49 @@                 f       doQuant vs Forall v f = doFormula (v : vs) f       doQuant vs Exists v f = fn (reverse vs) (exists v f)++-- ------------------------------------------------------------------------- +-- Apply a function to the atoms, otherwise keeping structure.               +-- ------------------------------------------------------------------------- ++mapAtomsFirstOrder :: forall formula atom v. FirstOrderFormula formula atom v => (atom -> formula) -> formula -> formula+mapAtomsFirstOrder f fm =+    foldFirstOrder qu co tf at fm+    where+      qu op v p = quant op v (mapAtomsFirstOrder f p)+      co ((:~:) p) = mapAtomsFirstOrder f p+      co (BinOp p op q) = binop (mapAtomsFirstOrder f p) op (mapAtomsFirstOrder f q)+      tf flag = fromBool flag+      at x = f x++-- | Deprecated - use mapAtoms+onatoms :: forall formula atom v. (FirstOrderFormula formula atom v) => (atom -> formula) -> formula -> formula+onatoms = mapAtomsFirstOrder++-- ------------------------------------------------------------------------- +-- Formula analog of list iterator "itlist".                                 +-- -------------------------------------------------------------------------++foldAtomsFirstOrder :: FirstOrderFormula fof atom v => (r -> atom -> r) -> r -> fof -> r+foldAtomsFirstOrder f i fof =+        foldFirstOrder qu co (const i) (f i) fof+        where+          qu _ _ fof' = foldAtomsFirstOrder f i fof'+          co ((:~:) fof') = foldAtomsFirstOrder f i fof'+          co (BinOp p _ q) = foldAtomsFirstOrder f (foldAtomsFirstOrder f i q) p++-- | Deprecated - use foldAtoms+overatoms :: forall formula atom v r. FirstOrderFormula formula atom v =>+             (atom -> r -> r) -> formula -> r -> r+overatoms f fm b = foldAtomsFirstOrder (flip f) b fm++-- ------------------------------------------------------------------------- +-- Special case of a union of the results of a function over the atoms.      +-- ------------------------------------------------------------------------- ++atom_union :: forall formula atom v a. (FirstOrderFormula formula atom v, Ord a) =>+              (atom -> Set.Set a) -> formula -> Set.Set a+atom_union f fm = overatoms (\ h t -> Set.union (f h) t) fm Set.empty  $(deriveSafeCopy 1 'base ''Quant)
+ Data/Logic/Classes/Formula.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Data.Logic.Classes.Formula+    ( Formula(atomic, foldAtoms, mapAtoms)+    ) where++class Formula formula atom where+    atomic :: atom -> formula+    foldAtoms :: Formula formula atom => (r -> atom -> r) -> r -> formula -> r+    mapAtoms :: Formula formula atom => (atom -> formula) -> formula -> formula
Data/Logic/Classes/Literal.hs view
@@ -5,22 +5,27 @@     , zipLiterals     , fromFirstOrder     , fromLiteral+    , toPropositional     , prettyLit+    , foldAtomsLiteral     ) where +import Control.Applicative.Error (Failing(..)) import Data.Logic.Classes.Combine (Combination(..)) import Data.Logic.Classes.Constants import qualified Data.Logic.Classes.FirstOrder as FOF+import Data.Logic.Classes.Formula (Formula(atomic))+import Data.Logic.Classes.Pretty (HasFixity(..), Fixity(..), FixityDirection(..))+import qualified Data.Logic.Classes.Propositional as P import Data.Logic.Classes.Negate-import Text.PrettyPrint (Doc, (<>), text)+import Text.PrettyPrint (Doc, (<>), text, parens, nest)  -- |Literals are the building blocks of the clause and implicative normal -- |forms.  They support negation and must include True and False elements.-class (Negatable lit, Constants lit) => Literal lit atom v | lit -> atom v where+class (Negatable lit, Constants lit, HasFixity atom, Formula lit atom, Ord lit) => Literal lit atom | lit -> atom where     foldLiteral :: (lit -> r) -> (Bool -> r) -> (atom -> r) -> lit -> r-    atomic :: atom -> lit -zipLiterals :: Literal lit atom v =>+zipLiterals :: Literal lit atom =>                (lit -> lit -> Maybe r)             -> (Bool -> Bool -> Maybe r)             -> (atom -> atom -> Maybe r)@@ -45,20 +50,24 @@ -- |Just like Logic.FirstOrder.convertFOF except it rejects anything -- with a construct unsupported in a normal logic formula, -- i.e. quantifiers and formula combinators other than negation.-fromFirstOrder :: forall formula atom v lit atom2 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+fromFirstOrder :: forall formula atom v lit atom2.+                  (Formula lit atom2, FOF.FirstOrderFormula formula atom v, Literal lit atom2) =>+                  (atom -> atom2) -> formula -> Failing lit+fromFirstOrder ca formula =+    FOF.foldFirstOrder (\ _ _ _ -> Failure ["fromFirstOrder"]) co (Success . fromBool) (Success . atomic . ca) formula     where-      co :: Combination formula -> lit-      co ((:~:) f) =  (.~.) (fromFirstOrder ca cv f)-      co _ = error "FirstOrder -> Literal"+      co :: Combination formula -> Failing lit+      co ((:~:) f) =  fromFirstOrder ca f >>= return . (.~.)+      co _ = Failure ["fromFirstOrder"] -fromLiteral :: forall lit atom v fof atom2 v2. (Literal lit atom v, FOF.FirstOrderFormula fof atom2 v2) =>+fromLiteral :: forall lit atom v fof atom2. (Literal lit atom, FOF.FirstOrderFormula fof atom2 v) =>                (atom -> atom2) -> lit -> fof-fromLiteral ca lit = foldLiteral (\ p -> (.~.) (fromLiteral ca p)) fromBool (FOF.atomic . ca) lit+fromLiteral ca lit = foldLiteral (\ p -> (.~.) (fromLiteral ca p)) fromBool (atomic . ca) lit +toPropositional :: forall lit atom pf atom2. (Literal lit atom, P.PropositionalFormula pf atom2) =>+                   (atom -> atom2) -> lit -> pf+toPropositional ca lit = foldLiteral (\ p -> (.~.) (toPropositional ca p)) fromBool (atomic . ca) lit+ {- prettyLit :: forall lit atom term v p f. (Literal lit atom v, Apply atom p term, Term term v f) =>               (v -> Doc)@@ -82,16 +91,30 @@       -- parensIf _ = parens . nest 1 -} -prettyLit :: forall lit atom v. (Literal lit atom v) =>+prettyLit :: forall lit atom v. (Literal lit atom) =>               (Int -> atom -> Doc)            -> (v -> Doc)            -> Int            -> lit            -> Doc-prettyLit pa pv prec lit =-    foldLiteral co tf at lit+prettyLit pa pv pprec lit =+    parensIf (pprec > prec) $ foldLiteral co tf at lit     where       co :: lit -> Doc       co x = if negated x then text {-"¬"-} "~" <> prettyLit pa pv 5 x else prettyLit pa pv 5 x       tf x = text (if x then "true" else "false")       at = pa 6+      parensIf False = id+      parensIf _ = parens . nest 1+      Fixity prec _ = fixityLiteral lit++fixityLiteral :: (Literal formula atom) => formula -> Fixity+fixityLiteral formula =+    foldLiteral neg tf at formula+    where+      neg _ = Fixity 5 InfixN+      tf _ = Fixity 10 InfixN+      at = fixity++foldAtomsLiteral :: Literal lit atom => (r -> atom -> r) -> r -> lit -> r+foldAtomsLiteral f i lit = foldLiteral (foldAtomsLiteral f i) (const i) (f i) lit
+ Data/Logic/Classes/Pretty.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+module Data.Logic.Classes.Pretty+    ( Pretty(pretty)+    , HasFixity(fixity)+    , TH.Fixity(..)+    , TH.FixityDirection(..)+    , topFixity+    , botFixity+    ) where++import qualified Language.Haskell.TH.Syntax as TH+import Text.PrettyPrint (Doc, text)++-- | The intent of this class is to be similar to Show, but only one+-- way, with no corresponding Read class.  It doesn't really belong+-- here in logic-classes.  To put something in a pretty printing class+-- implies that there is only one way to pretty print it, which is not+-- an assumption made by Text.PrettyPrint.  But in practice this is+-- often good enough.+class Pretty x where+    pretty :: x -> Doc++-- | A class used to do proper parenthesization of formulas.  If we+-- nest a higher precedence formula inside a lower one parentheses can+-- be omitted.  Because @|@ has lower precedence than @&@, the formula+-- @a | (b & c)@ appears as @a | b & c@, while @(a | b) & c@ appears+-- unchanged.  (Name Precedence chosen because Fixity was taken.)+-- +-- The second field of Fixity is the FixityDirection, which can be+-- left, right, or non.  A left associative operator like @/@ is+-- grouped left to right, so parenthese can be omitted from @(a / b) /+-- c@ but not from @a / (b / c)@.  It is a syntax error to omit+-- parentheses when formatting a non-associative operator.+-- +-- The Haskell FixityDirection type is concerned with how to interpret+-- a formula formatted in a certain way, but here we are concerned+-- with how to format a formula given its interpretation.  As such,+-- one case the Haskell type does not capture is whether the operator+-- follows the associative law, so we can omit parentheses in an+-- expression such as @a & b & c@.+class HasFixity x where+    fixity :: x -> TH.Fixity++-- Definitions from template-haskell:+-- data Fixity = Fixity Int FixityDirection+-- data FixityDirection = InfixL | InfixR | InfixN++-- | This is used as the initial value for the parent fixity.+topFixity :: TH.Fixity+topFixity = TH.Fixity 0 TH.InfixN++-- | This is used as the fixity for things that never need+-- parenthesization, such as function application.+botFixity :: TH.Fixity+botFixity = TH.Fixity 10 TH.InfixN++instance Pretty String where+    pretty = text
Data/Logic/Classes/Propositional.hs view
@@ -12,6 +12,8 @@ module Data.Logic.Classes.Propositional     ( PropositionalFormula(..)     , showPropositional+    , prettyPropositional+    , fixityPropositional     , convertProp     , combine     , negationNormalForm@@ -21,14 +23,20 @@     , clauseNormalFormAlt'     , disjunctiveNormalForm     , disjunctiveNormalForm'+    , overatoms+    , foldAtomsPropositional+    , mapAtomsPropositional     ) where  import Data.Logic.Classes.Combine-import Data.Logic.Classes.Constants+import Data.Logic.Classes.Constants (Constants(fromBool), asBool, prettyBool)+import Data.Logic.Classes.Formula (Formula(atomic)) import Data.Logic.Classes.Negate+import Data.Logic.Classes.Pretty (Pretty, HasFixity(fixity), Fixity(Fixity), FixityDirection(..)) import Data.SafeCopy (base, deriveSafeCopy) import qualified Data.Set.Extra as Set import Happstack.Data (deriveNewData)+import Text.PrettyPrint (Doc, text, (<>))  -- |A type class for propositional logic.  If the type we are writing -- an instance for is a zero-order (aka propositional) logic type@@ -38,9 +46,16 @@ -- 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 (Combinable formula, Constants formula) => PropositionalFormula formula atom | formula -> atom where+-- +-- The Ord superclass is required so we can put formulas in sets+-- during the normal form computations.  Negatable and Combinable are+-- also considered basic operations that we can't build this package+-- without.  It is less obvious whether Constants is always required,+-- but the implementation of functions like simplify would be more+-- elaborate if we didn't have it, so we will require it.+class (Ord formula, Negatable formula, Combinable formula, Constants formula,+       Pretty formula, HasFixity formula, Formula formula atom) => PropositionalFormula formula atom | formula -> atom where     -- | Build an atomic formula from the atom type.-    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@@ -66,6 +81,37 @@       showFormOp (:&:) = ".&."       showFormOp (:|:) = ".|." +-- | Show a formula in a visually pleasing format.+prettyPropositional :: (PropositionalFormula formula atom, HasFixity formula) =>+                       (atom -> Doc)+                    -> Fixity        -- ^ The fixity of the parent formula.  If the operator being formatted here+                                     -- has a lower precedence it needs to be parenthesized.+                    -> formula+                    -> Doc+prettyPropositional prettyAtom (Fixity pprec _pdir) formula =+    parenIf (pprec > prec) (foldPropositional co tf at formula)+    where+      co ((:~:) f) = text "¬" <> prettyPropositional prettyAtom fix f+      co (BinOp f1 op f2) = prettyPropositional prettyAtom fix f1 <> text " " <> prettyBinOp op <> text " " <> prettyPropositional prettyAtom fix f2+      tf = prettyBool+      at = prettyAtom+      -- parenForm x = cat [text "(", prettyPropositional prettyAtom 0 x, text ")"]+      parenIf True x = text "(" <> x <> text ")"+      parenIf False x = x+      fix@(Fixity prec _dir) = fixity formula++fixityPropositional :: (HasFixity atom, PropositionalFormula formula atom) => formula -> Fixity+fixityPropositional formula =+    foldPropositional co tf at formula+    where+      co ((:~:) _) = Fixity 5 InfixN+      co (BinOp _ (:&:) _) = Fixity 4 InfixL+      co (BinOp _ (:|:) _) = Fixity 3 InfixL+      co (BinOp _ (:=>:) _) = Fixity 2 InfixR+      co (BinOp _ (:<=>:) _) = Fixity 1 InfixL+      tf _ = Fixity 10 InfixN+      at = fixity+ -- |Convert any instance of a propositional logic expression to any -- other using the supplied atom conversion function. convertProp :: forall formula1 atom1 formula2 atom2.@@ -81,7 +127,7 @@       a = atomic . convertA  -- | Simplify and recursively apply nnf.-negationNormalForm :: (PropositionalFormula formula atom, Eq formula) => formula -> formula+negationNormalForm :: (PropositionalFormula formula atom) => formula -> formula negationNormalForm = nnf . psimplify  -- |Eliminate => and <=> and move negations inwards:@@ -97,18 +143,17 @@ -- ~~P  P -- @ -- -nnf :: PropositionalFormula formula atom => formula -> formula-nnf fm =-    foldPropositional (nnfCombine fm) fromBool (\ _ -> fm) fm+nnf :: (PropositionalFormula formula atom) => formula -> formula+nnf fm = foldPropositional (nnfCombine fm) fromBool (\ _ -> fm) fm -nnfCombine :: PropositionalFormula r atom => r -> Combination r -> r+nnfCombine :: (PropositionalFormula formula atom) => formula -> Combination formula -> formula nnfCombine fm ((:~:) p) = foldPropositional nnfNotCombine (fromBool . not) (\ _ -> fm) p nnfCombine _ (BinOp p (:=>:) q) = nnf ((.~.) p) .|. (nnf q) nnfCombine _ (BinOp p (:<=>:) q) =  (nnf p .&. nnf q) .|. (nnf ((.~.) p) .&. nnf ((.~.) q)) nnfCombine _ (BinOp p (:&:) q) = nnf p .&. nnf q nnfCombine _ (BinOp p (:|:) q) = nnf p .|. nnf q -nnfNotCombine :: PropositionalFormula formula atom => Combination formula -> formula+nnfNotCombine :: (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)@@ -116,7 +161,7 @@ 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, Eq formula) => formula -> formula+psimplify :: (PropositionalFormula formula atom) => formula -> formula psimplify fm =     foldPropositional co tf at fm     where@@ -147,7 +192,7 @@ --  False <=> P -> ~P -- @ -- -psimplify1 :: forall formula atom. (PropositionalFormula formula atom, Eq formula) => formula -> formula+psimplify1 :: forall formula atom. (PropositionalFormula formula atom) => formula -> formula psimplify1 fm =     foldPropositional simplifyCombine (\ _ -> fm) (\ _ -> fm) fm     where@@ -166,6 +211,7 @@             (Just False, (:=>:), _)           -> fromBool True             (_,          (:=>:), Just True)   -> fromBool True             (_,          (:=>:), Just False)  -> (.~.) l+            (Just False, (:<=>:), Just False) -> fromBool True             (Just True,  (:<=>:), _)          -> r             (Just False, (:<=>:), _)          -> (.~.) r             (_,          (:<=>:), Just True)  -> l@@ -175,10 +221,10 @@       simplifyNotCombine _ = fm       simplifyNotAtom x = (.~.) (atomic x) -clauseNormalForm' :: (PropositionalFormula formula atom, Ord formula) => formula -> Set.Set (Set.Set formula)+clauseNormalForm' :: (PropositionalFormula formula atom) => formula -> Set.Set (Set.Set formula) clauseNormalForm' = simp purecnf . negationNormalForm -clauseNormalForm :: forall formula atom. (PropositionalFormula formula atom, Ord formula) => formula -> formula+clauseNormalForm :: forall formula atom. (PropositionalFormula formula atom) => formula -> formula clauseNormalForm formula =     case clean (lists cnf) of       [] -> fromBool True@@ -189,10 +235,10 @@       cnf = clauseNormalForm' formula  -- |I'm not sure of the clauseNormalForm functions above are wrong or just different.-clauseNormalFormAlt' :: (PropositionalFormula formula atom, Ord formula) => formula -> Set.Set (Set.Set formula)+clauseNormalFormAlt' :: (PropositionalFormula formula atom) => formula -> Set.Set (Set.Set formula) clauseNormalFormAlt' = simp purecnf' . negationNormalForm -clauseNormalFormAlt :: forall formula atom. (PropositionalFormula formula atom, Ord formula) => formula -> formula+clauseNormalFormAlt :: forall formula atom. (PropositionalFormula formula atom) => formula -> formula clauseNormalFormAlt formula =     case clean (lists cnf) of       [] -> fromBool True@@ -202,7 +248,7 @@       lists = Set.toList . Set.map Set.toList       cnf = clauseNormalFormAlt' formula -disjunctiveNormalForm :: (PropositionalFormula formula atom, Ord formula) => formula -> formula+disjunctiveNormalForm :: (PropositionalFormula formula atom) => formula -> formula disjunctiveNormalForm formula =     case clean (lists dnf) of       [] -> fromBool False@@ -212,10 +258,10 @@       lists = Set.toList . Set.map Set.toList       dnf = disjunctiveNormalForm' formula -disjunctiveNormalForm' :: (PropositionalFormula formula atom, Eq formula, Ord formula) => formula -> Set.Set (Set.Set formula)+disjunctiveNormalForm' :: (PropositionalFormula formula atom, Eq formula) => formula -> Set.Set (Set.Set formula) disjunctiveNormalForm' = simp purednf . negationNormalForm -simp :: forall formula atom. (PropositionalFormula formula atom, Eq formula, Ord formula) =>+simp :: forall formula atom. (PropositionalFormula formula atom) =>         (formula -> Set.Set (Set.Set formula)) -> formula -> Set.Set (Set.Set formula) simp purenf fm =     case (compare fm (fromBool False), compare fm (fromBool True)) of@@ -234,11 +280,10 @@     not . Set.null $ Set.intersection (Set.map (.~.) n) p     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, Eq formula, Ord formula) => formula -> Set.Set (Set.Set formula)+purecnf :: forall formula atom. (PropositionalFormula formula atom) => formula -> Set.Set (Set.Set formula) purecnf fm = Set.map (Set.map (.~.)) (purednf (nnf ((.~.) fm))) -purednf :: forall formula atom. (PropositionalFormula formula atom, Ord formula) => formula -> Set.Set (Set.Set formula)+purednf :: forall formula atom. (PropositionalFormula formula atom) => formula -> Set.Set (Set.Set formula) purednf fm =     foldPropositional c (\ _ -> x) (\ _ -> x)  fm     where@@ -249,7 +294,7 @@       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, Eq formula, Ord formula) => formula -> Set.Set (Set.Set formula)+purecnf' :: forall formula atom. (PropositionalFormula formula atom) => formula -> Set.Set (Set.Set formula) purecnf' fm =     foldPropositional c (\ _ -> x) (\ _ -> x)  fm     where@@ -259,6 +304,31 @@       c _ = x       x :: Set.Set (Set.Set formula)       x = Set.singleton (Set.singleton (convertProp id fm)) :: Set.Set (Set.Set formula)++-- ------------------------------------------------------------------------- +-- Formula analog of list iterator "itlist".                                 +-- ------------------------------------------------------------------------- ++-- | Use this to implement foldAtoms+foldAtomsPropositional :: PropositionalFormula pf atom => (r -> atom -> r) -> r -> pf -> r+foldAtomsPropositional f i pf =+        foldPropositional co (const i) (f i) pf+        where+          co ((:~:) pf') = foldAtomsPropositional f i pf'+          co (BinOp p _ q) = foldAtomsPropositional f (foldAtomsPropositional f i q) p++-- | Deprecated - use foldAtoms.+overatoms :: forall formula atom r. PropositionalFormula formula atom => (atom -> r -> r) -> formula -> r -> r+overatoms f fm b = foldAtomsPropositional (flip f) b fm++mapAtomsPropositional :: forall formula atom. PropositionalFormula formula atom => (atom -> formula) -> formula -> formula+mapAtomsPropositional f fm =+    foldPropositional co tf at fm+    where+      co ((:~:) p) = mapAtomsPropositional f p+      co (BinOp p op q) = binop (mapAtomsPropositional f p) op (mapAtomsPropositional f q)+      tf flag = fromBool flag+      at x = f x  $(deriveSafeCopy 1 'base ''BinOp) $(deriveSafeCopy 1 'base ''Combination)
Data/Logic/Classes/Skolem.hs view
@@ -1,7 +1,15 @@+{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-} module Data.Logic.Classes.Skolem where +import Data.Logic.Classes.Variable (Variable)+ -- |This class shows how to convert between atomic Skolem functions--- and Ints.-class Skolem f where-    toSkolem :: Int -> f-    fromSkolem  :: f -> Maybe Int+-- and Ints.  We include a variable type as a parameter because we+-- create skolem functions to replace an existentially quantified+-- variable, and it can be helpful to retain a reference to the+-- variable.+class Variable v => Skolem f v | f -> v where+    toSkolem :: v -> f+    -- ^ Built a Skolem function from the given variable and number.+    -- The number is generally obtained from the skolem monad.+    isSkolem  :: f -> Bool
Data/Logic/Classes/Term.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-} module Data.Logic.Classes.Term     ( Term(..)-    -- , Function(..)+    , Function     , convertTerm     , showTerm     , prettyTerm@@ -12,6 +12,7 @@  import Data.Generics (Data) import Data.List (intercalate, intersperse)+import Data.Logic.Classes.Pretty (Pretty) import Data.Logic.Classes.Skolem import Data.Logic.Classes.Variable import qualified Data.Map as Map@@ -19,18 +20,11 @@ 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 (Eq f, Ord f, Skolem f v, Data f, Pretty f) => Function f v -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 f where+class ( Ord term  -- For implementing Ord in Literal+      , Variable v+      , Function f v ) => Term term v f | term -> v f where     vt :: v -> term     -- ^ Build a term which is a variable reference.     fApp :: f -> [term] -> term
Data/Logic/Classes/Variable.hs view
@@ -4,11 +4,13 @@     , showVariable     ) where +import Data.Data (Data)+import Data.Logic.Classes.Pretty (Pretty) import qualified Data.Set as Set import Data.String (IsString) import Text.PrettyPrint (Doc) -class (Ord v, IsString v) => Variable v where+class (Ord v, IsString v, Data v, Pretty v) => Variable v where     variant :: v -> Set.Set v -> v     -- ^ Return a variable based on v but different from any set     -- element.  The result may be v itself if v is not a member of@@ -28,29 +30,3 @@  showVariable :: Variable v => v -> String showVariable v = "fromString (" ++ show (show (prettyVariable v)) ++ ")"--{--module Data.Logic.Classes.Variable-    ( Variable(one, next)-    , variant-    ) where--import qualified Data.Set as S---- |A class for finding unused variable names.  The next method--- returns the next in an endless sequence of variable names, if we--- keep calling it we are bound to find some unused name.-class Variable v where-    one :: v-    -- ^ Return some commonly used variable, typically x-    next :: v -> v-    -- ^ Return a different variable name, @iterate next one@ should-    -- return a list which never repeats.---- |Find a variable name which is not in the variables set which is--- stored in the monad.  This is initialized above with the free--- variables in the formula.  (FIXME: this is not worth putting in--- 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/DP.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, ScopedTypeVariables #-}+module Data.Logic.Harrison.DP+    ( tests+    , dpll+    ) where++import Control.Applicative.Error (Failing(..))+import Data.Logic.Classes.Literal (Literal)+import Data.Logic.Classes.Negate (Negatable, (.~.), negated)+import Data.Logic.Classes.Propositional (PropositionalFormula(..))+import Data.Logic.Harrison.DefCNF (NumAtom(..), defcnfs)+import Data.Logic.Harrison.Lib (allpairs, maximize', minimize', defined, setmapfilter, (|->))+import Data.Logic.Harrison.Prop (negative, positive, trivial, tautology, cnf)+import Data.Logic.Harrison.PropExamples (Atom(..), N, prime)+import Data.Logic.Tests.HUnit+import Data.Logic.Types.Propositional (Formula(..))+import qualified Data.Map as Map+import qualified Data.Set.Extra as Set++import Debug.Trace++instance NumAtom (Atom N) where+    ma n = P "p" n Nothing+    ai (P _ n _) = n++tests = convert (TestList [test01, test02, test03])++-- ========================================================================= +-- The Davis-Putnam and Davis-Putnam-Loveland-Logemann procedures.           +--                                                                           +-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)  +-- ========================================================================= ++-- ------------------------------------------------------------------------- +-- The DP procedure.                                                         +-- ------------------------------------------------------------------------- ++one_literal_rule :: (Literal lit atom, Ord lit) => Set.Set (Set.Set lit) -> Failing (Set.Set (Set.Set lit))+one_literal_rule clauses =+    case Set.minView (Set.filter (\ cl -> Set.size cl == 1) clauses) of+      Nothing -> Failure ["one_literal_rule"]+      Just (s, _) ->+          let u = Set.findMin s in+          let u' = (.~.) u in+          let clauses1 = Set.filter (\ cl -> not (Set.member u cl)) clauses in+          Success (Set.map (\ cl -> Set.delete u' cl) clauses1)++affirmative_negative_rule :: (Literal lit atom, Ord lit) => Set.Set (Set.Set lit) -> Failing (Set.Set (Set.Set lit))+affirmative_negative_rule clauses =+  let (neg',pos) = Set.partition negative (Set.flatten clauses) in+  let neg = Set.map (.~.) neg' in+  let pos_only = Set.difference pos neg+      neg_only = Set.difference neg pos in+  let pure = Set.union pos_only (Set.map (.~.) neg_only) in+  if Set.null pure+  then Failure ["affirmative_negative_rule"]+  else Success (Set.filter (\ cl -> Set.null (Set.intersection cl pure)) clauses)++resolve_on :: forall lit atom. (Literal lit atom, Ord lit) =>+              lit -> Set.Set (Set.Set lit) -> Set.Set (Set.Set lit)+resolve_on p clauses =+  let p' = (.~.) p+      (pos,notpos) = Set.partition (Set.member p) clauses in+  let (neg,other) = Set.partition (Set.member p') notpos in+  let pos' = Set.map (Set.filter (\ l -> l /= p)) pos+      neg' = Set.map (Set.filter (\ l -> l /= p')) neg in+  let res0 = allpairs Set.union pos' neg' in+  Set.union other (Set.filter (not . trivial) res0)++resolution_blowup :: forall formula. (Negatable formula, Ord formula) =>+                     Set.Set (Set.Set formula) -> formula -> Int+resolution_blowup cls l =+  let m = Set.size (Set.filter (Set.member l) cls)+      n = Set.size (Set.filter (Set.member ((.~.) l)) cls) in+  m * n - m - n++resolution_rule :: forall lit atom. (Literal lit atom, Ord lit) =>+                   Set.Set (Set.Set lit) -> Failing (Set.Set (Set.Set lit))+resolution_rule clauses =+    let pvs = Set.filter positive (Set.flatten clauses) in+    case minimize' (resolution_blowup clauses) pvs of+      Just p -> Success (resolve_on p clauses)+      Nothing -> Failure ["resolution_rule"]++-- ------------------------------------------------------------------------- +-- Overall procedure.                                                        +-- ------------------------------------------------------------------------- ++dp :: forall lit atom. (Literal lit atom, Ord lit) => Set.Set (Set.Set lit) -> Failing Bool        +dp clauses =+  if Set.null clauses+  then Success True+  else if Set.member Set.empty clauses+       then Success False+       else case one_literal_rule clauses >>= dp of+              Success x -> Success x+              Failure _ ->+                  case affirmative_negative_rule clauses >>= dp of+                    Success x -> Success x+                    Failure _ -> resolution_rule clauses >>= dp++-- ------------------------------------------------------------------------- +-- Davis-Putnam satisfiability tester and tautology checker.                 +-- ------------------------------------------------------------------------- ++dpsat :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom, NumAtom atom, Ord pf) => pf -> Failing Bool+dpsat fm = dp (defcnfs fm :: Set.Set (Set.Set pf))++dptaut :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom, NumAtom atom, Ord pf) => pf -> Failing Bool+dptaut fm = dpsat((.~.) fm) >>= return . not++-- ------------------------------------------------------------------------- +-- Examples.                                                                 +-- ------------------------------------------------------------------------- ++test01 = TestCase (assertEqual "dptaut(prime 11)" (Success True) (dptaut(prime 11 :: Formula (Atom N)))) ++-- ------------------------------------------------------------------------- +-- The same thing but with the DPLL procedure.                               +-- ------------------------------------------------------------------------- ++posneg_count :: forall formula. (Negatable formula, Ord formula) =>+                Set.Set (Set.Set formula) -> formula -> Int+posneg_count cls l =                         +  let m = Set.size(Set.filter (Set.member l) cls)                 +      n = Set.size(Set.filter (Set.member ((.~.) l)) cls) in+  m + n                                  ++dpll :: forall lit atom. (Literal lit atom, Ord lit) =>+        Set.Set (Set.Set lit) -> Failing Bool+dpll clauses =       +  if clauses == Set.empty+  then Success True+  else if Set.member Set.empty clauses+       then Success False+       else case one_literal_rule clauses >>= dpll of+              Success x -> Success x+              Failure _ ->+                  case affirmative_negative_rule clauses >>= dpll of+                    Success x -> Success x+                    Failure _ ->+                        let pvs = Set.filter positive (Set.flatten clauses) in+                        case maximize' (posneg_count clauses) pvs of+                          Nothing -> Failure ["dpll"]+                          Just p -> +                              case (dpll (Set.insert (Set.singleton p) clauses), dpll (Set.insert (Set.singleton ((.~.) p)) clauses)) of+                                (Success a, Success b) -> Success (a || b)+                                (Failure a, Failure b) -> Failure (a ++ b)+                                (Failure a, _) -> Failure a+                                (_, Failure b) -> Failure b++dpllsat :: forall pf. (PropositionalFormula pf (Atom N), Literal pf (Atom N), Ord pf) =>+           pf -> Failing Bool+dpllsat fm = dpll(defcnfs fm :: Set.Set (Set.Set pf))++dplltaut :: forall pf. (PropositionalFormula pf (Atom N), Literal pf (Atom N), Ord pf) =>+            pf -> Failing Bool+dplltaut fm = dpllsat ((.~.) fm) >>= return . not++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++test02 = TestCase (assertEqual "dplltaut(prime 11)" (Success True) (dplltaut(prime 11 :: Formula (Atom N)))) ++-- ------------------------------------------------------------------------- +-- Iterative implementation with explicit trail instead of recursion.        +-- ------------------------------------------------------------------------- ++data TrailMix = Guessed | Deduced deriving (Eq, Ord)++unassigned :: forall formula. (Negatable formula, Ord formula) =>+              Set.Set (Set.Set formula) -> Set.Set (formula, TrailMix) -> Set.Set formula+unassigned cls trail =+    Set.difference (Set.flatten (Set.map (Set.map litabs) cls)) (Set.map (litabs . fst) trail)+    where litabs p = if negated p then (.~.) p else p++unit_subpropagate :: forall formula. (Negatable formula, Ord formula) =>+                     (Set.Set (Set.Set formula), Map.Map formula (), Set.Set (formula, TrailMix))+                  -> (Set.Set (Set.Set formula), Map.Map formula (), Set.Set (formula, TrailMix))+unit_subpropagate (cls,fn,trail) =+  let cls' = Set.map (Set.filter (not . defined fn . (.~.))) cls in+  let uu cs =+          case Set.minView cs of+            Nothing -> Failure ["unit_subpropagate"]+            Just (c, _) -> if Set.size cs == 1 && not (defined fn c)+                           then Success cs+                           else Failure ["unit_subpropagate"] in+  let newunits = Set.flatten (setmapfilter uu cls') in+  if Set.null newunits then (cls',fn,trail) else+  let trail' = Set.fold (\ p t -> Set.insert (p,Deduced) t) trail newunits+      fn' = Set.fold (\ u -> (u |-> ())) fn newunits in+  unit_subpropagate (cls',fn',trail')++unit_propagate :: forall t. (Negatable t, Ord t) =>+                  (Set.Set (Set.Set t), Set.Set (t, TrailMix))+               -> (Set.Set (Set.Set t), Set.Set (t, TrailMix))+unit_propagate (cls,trail) =+  let fn = Set.fold (\ (x,_) -> (x |-> ())) Map.empty trail in+  let (cls',fn',trail') = unit_subpropagate (cls,fn,trail) in (cls',trail')++backtrack :: forall t. Set.Set (t, TrailMix) -> Set.Set (t, TrailMix)+backtrack trail =+  case Set.minView trail of+    Just ((p,Deduced), tt) -> backtrack tt+    _ -> trail++dpli :: forall atomic pf. (PropositionalFormula pf atomic, Ord pf) =>+        Set.Set (Set.Set pf) -> Set.Set (pf, TrailMix) -> Failing Bool+dpli cls trail =+  let (cls', trail') = unit_propagate (cls, trail) in+  if Set.member Set.empty cls' then+    case Set.minView trail of+      Just ((p,Guessed), tt) -> dpli cls (Set.insert ((.~.) p, Deduced) tt)+      _ -> Success False+  else+      case unassigned cls (trail' :: Set.Set (pf, TrailMix)) of+        s | Set.null s -> Success True+        ps -> case maximize' (posneg_count cls') ps of+                Just p -> dpli cls (Set.insert (p :: pf, Guessed) trail')+                Nothing -> Failure ["dpli"]++dplisat :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom, NumAtom atom, Ord pf) =>+           pf -> Failing Bool+dplisat fm = dpli (defcnfs fm :: Set.Set (Set.Set pf)) Set.empty++dplitaut :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom, NumAtom atom, Ord pf) =>+            pf -> Failing Bool+dplitaut fm = dplisat((.~.) fm) >>= return . not++-- ------------------------------------------------------------------------- +-- With simple non-chronological backjumping and learning.                   +-- ------------------------------------------------------------------------- ++backjump :: forall a. (Negatable a, Ord a) =>+            Set.Set (Set.Set a) -> a -> Set.Set (a, TrailMix) -> Set.Set (a, TrailMix)+backjump cls p trail =+  case Set.minView (backtrack trail) of+    Just ((q,Guessed), tt) ->+        let (cls',trail') = unit_propagate (cls, Set.insert (p,Guessed) tt) in+        if Set.member Set.empty cls' then backjump cls p tt else trail+    _ -> trail++dplb :: forall a. (Negatable a, Ord a) =>+        Set.Set (Set.Set a) -> Set.Set (a, TrailMix) -> Failing Bool+dplb cls trail =+  let (cls',trail') = unit_propagate (cls,trail) in+  if Set.member Set.empty cls' then+    case Set.minView (backtrack trail) of+      Just ((p,Guessed), tt) ->+        let trail'' = backjump cls p tt in+        let declits = Set.filter (\ (_,d) -> d == Guessed) trail'' in+        let conflict = Set.insert ((.~.) p) (Set.map ((.~.) . fst) declits) in+        dplb (Set.insert conflict cls) (Set.insert ((.~.) p,Deduced) trail'')+      _ -> Success False+  else+    case unassigned cls trail' of+      s | Set.null s -> Success True+      ps -> case maximize' (posneg_count cls') ps of+              Just p -> dplb cls (Set.insert (p,Guessed) trail')+              Nothing -> Failure ["dpib"]+            +dplbsat :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom, NumAtom atom, Ord pf) =>+           pf -> Failing Bool+dplbsat fm = dplb (defcnfs fm :: Set.Set (Set.Set pf)) Set.empty++dplbtaut :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom, NumAtom atom, Ord pf) =>+            pf -> Failing Bool+dplbtaut fm = dplbsat((.~.) fm) >>= return . not++-- ------------------------------------------------------------------------- +-- Examples.                                                                 +-- ------------------------------------------------------------------------- ++test03 = TestList [TestCase (assertEqual "dplitaut(prime 101)" (Success True) (dplitaut(prime 101 :: Formula (Atom N)))),+                   TestCase (assertEqual "dplbtaut(prime 101)" (Success True) (dplbtaut(prime 101 :: Formula (Atom N))))]
+ Data/Logic/Harrison/DefCNF.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables #-}+module Data.Logic.Harrison.DefCNF+    {- ( Atom+    , NumAtom(ma, ai)+    , defcnfs+    , defcnf1+    , defcnf2+    , defcnf3+    ) -} where++import Data.Logic.Classes.Combine (Combination(..), BinOp(..), (.&.), (.|.), (.<=>.))+import Data.Logic.Classes.Formula (Formula(atomic))+import Data.Logic.Classes.Literal (Literal)+import Data.Logic.Classes.Propositional (PropositionalFormula(foldPropositional), overatoms)+import Data.Logic.Harrison.Prop (nenf, simpcnf, cnf)+import Data.Logic.Harrison.PropExamples (N)+import qualified Data.Map as Map+import qualified Data.Set.Extra as Set++-- ========================================================================= +-- Definitional CNF.                                                         +--                                                                           +-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)  +-- ========================================================================= +{-+START_INTERACTIVE;;+cnf <<p <=> (q <=> r)>>;;+END_INTERACTIVE;;+-}+-- ------------------------------------------------------------------------- +-- Make a stylized variable and update the index.                            +-- ------------------------------------------------------------------------- ++data Atom a = P a++class NumAtom atom where+    ma :: N -> atom+    ai :: atom -> N++instance NumAtom (Atom N) where+    ma = P+    ai (P n) = n++mkprop :: forall pf atom. (PropositionalFormula pf atom, NumAtom atom) => N -> (pf, N)+mkprop n = (atomic (ma n :: atom), n + 1)++-- ------------------------------------------------------------------------- +-- Core definitional CNF procedure.                                          +-- ------------------------------------------------------------------------- ++maincnf :: (NumAtom atom, PropositionalFormula pf atom) => (pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int)+maincnf trip@(fm, _defs, _n) =+    foldPropositional co tf at fm+    where+      co (BinOp p (:&:) q) = defstep (.&.) (p,q) trip+      co (BinOp p (:|:) q) = defstep (.|.) (p,q) trip+      co (BinOp p (:<=>:) q) = defstep (.<=>.) (p,q) trip+      co (BinOp _ (:=>:) _) = trip+      co ((:~:) _) = trip+      tf _ = trip+      at _ = trip++defstep :: (PropositionalFormula pf atom, NumAtom atom, Ord pf) => (pf -> pf -> pf) -> (pf, pf) -> (pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int)+defstep op (p,q) (_fm, defs, n) =+  let (fm1,defs1,n1) = maincnf (p,defs,n) in+  let (fm2,defs2,n2) = maincnf (q,defs1,n1) in+  let fm' = op fm1 fm2 in+  case Map.lookup fm' defs2 of+    Just _ -> (fm', defs2, n2)+    Nothing -> let (v,n3) = mkprop n2 in (v, Map.insert v (v .<=>. fm') defs2,n3)++-- ------------------------------------------------------------------------- +-- Make n large enough that "v_m" won't clash with s for any m >= n          +-- ------------------------------------------------------------------------- ++max_varindex :: NumAtom atom =>  atom -> Int -> Int+max_varindex atom n = max n (ai atom)++-- ------------------------------------------------------------------------- +-- Overall definitional CNF.                                                 +-- ------------------------------------------------------------------------- ++mk_defcnf :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, NumAtom atom, Ord lit) =>+             ((pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int)) -> pf -> Set.Set (Set.Set lit)+mk_defcnf fn fm =+  let fm' = nenf fm in+  let n = 1 + overatoms max_varindex fm' 0 in+  let (fm'',defs,_) = fn (fm',Map.empty,n) in+  let (deflist {- :: [pf]-}) = Map.elems defs in+  Set.unions (simpcnf fm'' : map simpcnf deflist)++defcnf1 :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, NumAtom atom, Ord lit) => pf -> pf+defcnf1 fm = cnf (mk_defcnf maincnf fm :: Set.Set (Set.Set lit))+++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- +{-+START_INTERACTIVE;;+defcnf1 <<(p \/ (q /\ ~r)) /\ s>>;;+END_INTERACTIVE;;+-}+-- ------------------------------------------------------------------------- +-- Version tweaked to exploit initial structure.                             +-- ------------------------------------------------------------------------- ++subcnf :: (PropositionalFormula pf atom, NumAtom atom) =>+          ((pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int))+       -> (pf -> pf -> pf)+       -> pf+       -> pf+       -> (pf, Map.Map pf pf, Int)+       -> (pf, Map.Map pf pf, Int)+subcnf sfn op p q (_fm,defs,n) =+  let (fm1,defs1,n1) = sfn (p,defs,n) in+  let (fm2,defs2,n2) = sfn (q,defs1,n1) in+  (op fm1 fm2, defs2, n2)++orcnf :: (NumAtom atom, PropositionalFormula pf atom) => (pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int)+orcnf trip@(fm,_defs,_n) =+    foldPropositional co (\ _ -> maincnf trip) (\ _ -> maincnf trip) fm+    where+      co (BinOp p (:|:) q) = subcnf orcnf (.|.) p q trip+      co _ = maincnf trip++andcnf :: (PropositionalFormula pf atom, NumAtom atom, Ord pf) => (pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int)+andcnf trip@(fm,_defs,_n) =+    foldPropositional co (\ _ -> orcnf trip) (\ _ -> orcnf trip) fm+    where+      co (BinOp p (:&:) q) = subcnf andcnf (.&.) p q trip+      co _ = orcnf trip++defcnfs :: (PropositionalFormula pf atom, Literal lit atom, NumAtom atom, Ord lit) => pf -> Set.Set (Set.Set lit)+defcnfs fm = mk_defcnf andcnf fm++defcnf2 :: forall pf lit atom.(PropositionalFormula pf atom, Literal lit atom, NumAtom atom, Ord lit) => pf -> pf+defcnf2 fm = cnf (defcnfs fm :: Set.Set (Set.Set lit))++-- ------------------------------------------------------------------------- +-- Examples.                                                                 +-- ------------------------------------------------------------------------- +{-+START_INTERACTIVE;;+defcnf <<(p \/ (q /\ ~r)) /\ s>>;;+END_INTERACTIVE;;+-}+-- ------------------------------------------------------------------------- +-- Version that guarantees 3-CNF.                                            +-- ------------------------------------------------------------------------- ++andcnf3 :: (PropositionalFormula pf atom, NumAtom atom, Ord pf) => (pf, Map.Map pf pf, Int) -> (pf, Map.Map pf pf, Int)+andcnf3 trip@(fm,_defs,_n) =+    foldPropositional co (\ _ -> maincnf trip) (\ _ -> maincnf trip) fm+    where+      co (BinOp p (:&:) q) = subcnf andcnf3 (.&.) p q trip+      co _ = maincnf trip++defcnf3 :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, NumAtom atom, Ord lit) => pf -> pf+defcnf3 fm = cnf (mk_defcnf andcnf3 fm :: Set.Set (Set.Set lit))
Data/Logic/Harrison/Equal.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables, TypeSynonymInstances #-} {-# OPTIONS_GHC -Wall #-} module Data.Logic.Harrison.Equal-    ( function_congruence+{-  ( function_congruence     , equalitize-    ) where+    ) -} where  -- =========================================================================  -- First order logic with equality.                                          @@ -11,36 +11,36 @@ -- 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.Formula (Formula(atomic, foldAtoms)) import Data.Logic.Classes.Term (Term(..)) import Data.Logic.Harrison.Formulas.FirstOrder (atom_union) import Data.Logic.Harrison.Lib ((∅))-import Data.Logic.Harrison.Skolem (functions)+-- import 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+-- 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.                                       @@ -118,8 +118,8 @@ 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)))]+    [(∀) "x" (x .=. x),+     (∀) "x" ((∀) "y" ((∀) "z" (x .=. y ∧ x .=. z ⇒ y .=. z)))]     where       x :: term       x = vt (fromString "x")@@ -128,16 +128,21 @@       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) =>+equalitize :: forall formula atom term v p f. (FirstOrderFormula formula atom v, Formula formula atom, AtomEq atom p term, Ord p, Show p, Term term v f, Ord formula, Ord f) =>               formula -> formula equalitize fm =     if not (Set.member Equals allpreds)     then fm     else foldr1 (∧) (Set.toList axioms) ⇒ fm     where-      axioms = Set.fold (Set.union . function_congruence) (Set.fold (Set.union . predicate_congruence) equivalence_axioms preds) (functions funcsAtomEq fm)+      axioms = Set.fold (Set.union . function_congruence) (Set.fold (Set.union . predicate_congruence) equivalence_axioms preds) (functions' funcsAtomEq' fm)+      funcsAtomEq' :: atom -> Set.Set (f, Int)+      funcsAtomEq' = funcsAtomEq       allpreds = predicates fm       preds = Set.delete Equals allpreds++functions' :: forall formula atom f. (Formula formula atom, Ord f) => (atom -> Set.Set (f, Int)) -> formula -> Set.Set (f, Int)+functions' fa fm = foldAtoms (\ s a -> Set.union s (fa a)) Set.empty fm  -- -------------------------------------------------------------------------  -- Other variants not mentioned in book.
Data/Logic/Harrison/FOL.hs view
@@ -6,16 +6,20 @@     , list_conj     , var     , fv+    -- , fv'     , subst+    -- , subst'     , generalize     ) where  import Data.Logic.Classes.Apply (Apply(..), apply)+import Data.Logic.Classes.Atom (Atom(allVariables, substitute)) import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..), binop)-import Data.Logic.Classes.Constants (Constants (fromBool, true, false))+import Data.Logic.Classes.Constants (Constants (fromBool), true, false) import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), quant)-import Data.Logic.Classes.Formula (Formula(allVariables, substitute))+import Data.Logic.Classes.Formula (Formula(atomic)) import Data.Logic.Classes.Negate ((.~.))+import Data.Logic.Classes.Propositional (PropositionalFormula(..)) import Data.Logic.Classes.Term (Term(vt), fvt) import Data.Logic.Classes.Variable (Variable(..)) import Data.Logic.Harrison.Formulas.FirstOrder (on_atoms)@@ -61,8 +65,8 @@ -- 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)+on_formula :: forall fol atom term v p. (FirstOrderFormula fol atom v, Apply atom p term) => (term -> term) -> fol -> fol+on_formula f = on_atoms (foldApply (\ p ts -> atomic (apply p (map f ts) :: atom)) fromBool)  -- -------------------------------------------------------------------------  -- Parsing of terms.                                                         @@ -197,37 +201,55 @@ -- -------------------------------------------------------------------------   -- | 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 :: forall formula atom term v.+       (FirstOrderFormula formula atom v,+        Atom atom term v) => formula -> Set.Set v var fm =-    foldFirstOrder qu co tf allVariables fm+    foldFirstOrder qu co tf at fm     where       qu _ x p = Set.insert x (var p)       co ((:~:) p) = var p       co (BinOp p _ q) = Set.union (var p) (var q)       tf _ = Set.empty+      at :: atom -> Set.Set v+      at = allVariables  -- | Return the variables that occur free in a formula.-fv :: forall formula atom term v. (FirstOrderFormula formula atom v, Formula atom term v) => formula -> Set.Set v+fv :: forall formula atom term v.+      (FirstOrderFormula formula atom v,+       Atom atom term v) => formula -> Set.Set v fv fm =-    foldFirstOrder qu co tf allVariables fm+    foldFirstOrder qu co tf at fm     where       qu _ x p = Set.delete x (fv p)       co ((:~:) p) = fv p       co (BinOp p _ q) = Set.union (fv p) (fv q)       tf _ = Set.empty+      at = allVariables +-- | Return the variables in a propositional formula.+fv' :: forall formula atom term v. (PropositionalFormula formula atom, Atom atom term v, Ord v) => formula -> Set.Set v+fv' fm =+    foldPropositional co tf allVariables fm+    where+      co ((:~:) p) = fv' p+      co (BinOp p _ q) = Set.union (fv' p) (fv' q)+      tf _ = Set.empty+ -- -------------------------------------------------------------------------  -- Universal closure of a formula.                                            -- -------------------------------------------------------------------------  -generalize :: (FirstOrderFormula formula atom v, Formula atom term v) => formula -> formula+generalize :: (FirstOrderFormula formula atom v, Atom atom term v) => formula -> formula generalize fm = Set.fold for_all fm (fv fm)  -- -------------------------------------------------------------------------  -- Substitution in formulas, with variable renaming.                          -- -------------------------------------------------------------------------  -subst :: (FirstOrderFormula formula atom v, Formula atom term v, Term term v f) =>+subst :: (FirstOrderFormula formula atom v,+          Term term v f,+          Atom atom term v) =>          Map.Map v term -> formula -> formula subst env fm =     foldFirstOrder qu co tf at fm@@ -239,6 +261,19 @@                  else x       co ((:~:) p) = ((.~.) (subst env p))       co (BinOp p op q) = binop (subst env p) op (subst env q)+      tf = fromBool+      at = atomic . substitute env++subst' :: (PropositionalFormula formula atom,+           -- Formula formula term v,+           Atom atom term v,+           Term term v f) =>+          Map.Map v term -> formula -> formula+subst' env fm =+    foldPropositional co tf at fm+    where+      co ((:~:) p) = ((.~.) (subst' env p))+      co (BinOp p op q) = binop (subst' env p) op (subst' env q)       tf = fromBool       at = atomic . substitute env
+ Data/Logic/Harrison/Herbrand.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+module Data.Logic.Harrison.Herbrand where++import Control.Applicative.Error (Failing(..))+import Data.Logic.Classes.Atom (Atom(substitute, freeVariables))+import Data.Logic.Classes.FirstOrder (FirstOrderFormula)+import Data.Logic.Classes.Formula (Formula(..))+import Data.Logic.Classes.Literal (Literal)+import Data.Logic.Classes.Negate ((.~.))+import Data.Logic.Classes.Propositional (PropositionalFormula)+import Data.Logic.Classes.Term (Term, fApp)+import Data.Logic.Harrison.DP (dpll)+import Data.Logic.Harrison.FOL (generalize)+import Data.Logic.Harrison.Lib (distrib', allpairs)+import Data.Logic.Harrison.Normal (trivial)+import Data.Logic.Harrison.Prop (eval, simpcnf, simpdnf)+import Data.Logic.Harrison.Skolem (runSkolem, skolemize, functions)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.String (IsString(..))++-- ========================================================================= +-- Relation between FOL and propositonal logic; Herbrand theorem.            +--                                                                           +-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)  +-- ========================================================================= ++-- ------------------------------------------------------------------------- +-- Propositional valuation.                                                  +-- ------------------------------------------------------------------------- ++pholds :: (PropositionalFormula formula atom, Ord atom) => (Map.Map atom Bool) -> formula -> Bool+pholds d fm = eval fm d++-- ------------------------------------------------------------------------- +-- Get the constants for Herbrand base, adding nullary one if necessary.     +-- ------------------------------------------------------------------------- ++herbfuns :: forall pf atom term v f. (PropositionalFormula pf atom, Formula pf atom, Atom atom term v, Term term v f, IsString f, Ord f) =>+            (atom -> Set.Set (f, Int))+         -> pf+         -> (Set.Set (f, Int), Set.Set (f, Int))+herbfuns fa fm =+  let (cns,fns) = Set.partition (\ (_,ar) -> ar == 0) (functions fa fm) in+  if Set.null cns then (Set.singleton (fromString "c",0),fns) else (cns,fns)++-- ------------------------------------------------------------------------- +-- Enumeration of ground terms and m-tuples, ordered by total fns.           +-- ------------------------------------------------------------------------- ++groundterms :: forall term v f. (Term term v f) =>+               Set.Set term -> Set.Set (f, Int) -> Int -> Set.Set term+groundterms cntms _ 0 = cntms+groundterms cntms funcs n =+    Set.fold terms Set.empty funcs+    where+      terms (f,m) l = Set.union (Set.map (fApp f) (groundtuples cntms funcs (n - 1) m)) l++groundtuples :: forall term v f. (Term term v f) =>+                Set.Set term -> Set.Set (f, Int) -> Int -> Int -> Set.Set [term]+groundtuples _ _ 0 0 = Set.singleton []+groundtuples _ _ _ 0 = Set.empty+groundtuples cntms funcs n m =+    Set.fold tuples Set.empty (Set.fromList [0 .. n])+    where +      tuples k l = Set.union (allpairs (:) (groundterms cntms funcs k) (groundtuples cntms funcs (n - k) (m - 1))) l++-- ------------------------------------------------------------------------- +-- Iterate modifier "mfn" over ground terms till "tfn" fails.                +-- ------------------------------------------------------------------------- ++herbloop :: forall lit atom v term f. (Literal lit atom, Term term v f, Atom atom term v) =>+            (Set.Set (Set.Set lit) -> (lit -> lit) -> Set.Set (Set.Set lit) -> Set.Set (Set.Set lit))+         -> (Set.Set (Set.Set lit) -> Failing Bool)+         -> Set.Set (Set.Set lit)+         -> Set.Set term+         -> Set.Set (f, Int)+         -> [v]+         -> Int+         -> Set.Set (Set.Set lit)+         -> Set.Set [term]+         -> Set.Set [term]+         -> Failing (Set.Set [term])+herbloop mfn tfn fl0 cntms funcs fvs n fl tried tuples =+{-+  print_string(string_of_int(length tried) ++ " ground instances tried; " +++               string_of_int(length fl) ++ " items in list")+  print_newline();+-}+  case Set.minView tuples of+    Nothing ->+          let newtups = groundtuples cntms funcs n (length fvs) in+          herbloop mfn tfn fl0 cntms funcs fvs (n + 1) fl tried newtups+    Just (tup, tups) ->+        let fpf' = Map.fromList (zip fvs tup) in+        let fl' = mfn fl0 (subst' fpf') fl in+        case tfn fl' of+          Failure msgs -> Failure msgs+          Success x ->+              if not x+              then Success (Set.insert tup tried)+              else herbloop mfn tfn fl0 cntms funcs fvs n fl' (Set.insert tup tried) tups++subst' :: forall lit atom term v f. (Literal lit atom, Atom atom term v, Term term v f) => Map.Map v term -> lit -> lit+subst' env fm =+    mapAtoms (atomic . substitute') fm+    where substitute' :: atom -> atom+          substitute' = substitute env++-- ------------------------------------------------------------------------- +-- Hence a simple Gilmore-type procedure.                                    +-- ------------------------------------------------------------------------- ++gilmore_loop :: (Literal lit atom, Term term v f, Atom atom term v, Ord lit) =>+                Set.Set (Set.Set lit)+             -> Set.Set term+             -> Set.Set (f, Int)+             -> [v]+             -> Int+             -> Set.Set (Set.Set lit)+             -> Set.Set [term]+             -> Set.Set [term]+             -> Failing (Set.Set [term])+gilmore_loop =+    herbloop mfn (Success . not . Set.null)+    where+      mfn djs0 ifn djs = Set.filter (not . trivial) (distrib' (Set.map (Set.map ifn) djs0) djs)++gilmore :: forall fof pf atom term v f.+           (FirstOrderFormula fof atom v,+            PropositionalFormula pf atom,+            Literal pf atom,+            Term term v f,+            Atom atom term v,+            IsString f,+            Ord pf) =>+           (atom -> Set.Set (f, Int)) -> fof -> Failing Int+gilmore fa fm =+  let sfm = runSkolem (skolemize id ((.~.)(generalize fm))) :: pf in+  let fvs = Set.toList (foldAtoms (\ s (a :: atom) -> Set.union s (freeVariables a)) Set.empty sfm)+      (consts,funcs) = herbfuns fa sfm in+  let cntms = Set.map (\ (c,_) -> fApp c []) consts in+  gilmore_loop (simpdnf sfm :: Set.Set (Set.Set pf)) cntms funcs (fvs) 0 Set.empty Set.empty Set.empty >>= return . Set.size++-- ------------------------------------------------------------------------- +-- First example and a little tracing.                                       +-- ------------------------------------------------------------------------- +{-+test01 =+    let fm = exists "x" (for_all "y" (pApp "p" [vt "x"] .=>. pApp "p" [vt "y"]))+        sfm = skolemize ((.~.) fm) in+    TestList [TestCase (assertEqual "gilmore 1" 2 (gilmore fm))]++START_INTERACTIVE;;+gilmore <<exists x. forall y. P(x) ==> P(y)>>;;++let sfm = skolemize(Not <<exists x. forall y. P(x) ==> P(y)>>);;++-- ------------------------------------------------------------------------- +-- Quick example.                                                            +-- ------------------------------------------------------------------------- ++let p24 = gilmore+ <<~(exists x. U(x) /\ Q(x)) /\+   (forall x. P(x) ==> Q(x) \/ R(x)) /\+   ~(exists x. P(x) ==> (exists x. Q(x))) /\+   (forall x. Q(x) /\ R(x) ==> U(x))+   ==> (exists x. P(x) /\ R(x))>>;;++-- ------------------------------------------------------------------------- +-- Slightly less easy example.                                               +-- ------------------------------------------------------------------------- ++let p45 = gilmore+ <<(forall x. P(x) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y))+              ==> (forall y. G(y) /\ H(x,y) ==> R(y))) /\+   ~(exists y. L(y) /\ R(y)) /\+   (exists x. P(x) /\ (forall y. H(x,y) ==> L(y)) /\+                      (forall y. G(y) /\ H(x,y) ==> J(x,y)))+   ==> (exists x. P(x) /\ ~(exists y. G(y) /\ H(x,y)))>>;;+END_INTERACTIVE;;+-}+-- ------------------------------------------------------------------------- +-- Apparently intractable example.                                           +-- ------------------------------------------------------------------------- ++{-++let p20 = gilmore+ <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w))+   ==> (exists x y. P(x) /\ Q(y)) ==> (exists z. R(z))>>;;++-}+++-- ------------------------------------------------------------------------- +-- The Davis-Putnam procedure for first order logic.                         +-- ------------------------------------------------------------------------- ++dp_mfn :: (Ord b, Ord a) =>+          Set.Set (Set.Set a)+       -> (a -> b)+       -> Set.Set (Set.Set b)+       -> Set.Set (Set.Set b)+dp_mfn cjs0 ifn cjs = Set.union (Set.map (Set.map ifn) cjs0) cjs++dp_loop :: forall lit atom v term f. (Literal lit atom, Term term v f, Atom atom term v, Ord lit) =>+           Set.Set (Set.Set lit)+        -> Set.Set term+        -> Set.Set (f, Int)+        -> [v]+        -> Int+        -> Set.Set (Set.Set lit)+        -> Set.Set [term]+        -> Set.Set [term]+        -> Failing (Set.Set [term])+dp_loop = herbloop dp_mfn dpll++davisputnam :: forall fof atom term v lit f.+               (FirstOrderFormula fof atom v,+                PropositionalFormula lit atom,+                Literal lit atom,+                Term term v f,+                Atom atom term v,+                IsString f,+                Ord lit) =>+               (atom -> Set.Set (f, Int)) -> fof -> Failing Int+davisputnam fa fm =+  let (sfm :: lit) = runSkolem (skolemize id ((.~.)(generalize fm))) in+  let fvs = Set.toList (foldAtoms (\ s (a :: atom) -> Set.union (freeVariables a) s) Set.empty sfm)+      (consts,funcs) = herbfuns fa sfm in+  let cntms = Set.map (\ (c,_) -> fApp c [] :: term) consts in+  dp_loop (simpcnf sfm :: Set.Set (Set.Set lit)) cntms funcs fvs 0 Set.empty Set.empty Set.empty >>= return . Set.size++-- ------------------------------------------------------------------------- +-- Show how much better than the Gilmore procedure this can be.              +-- ------------------------------------------------------------------------- ++{-+START_INTERACTIVE;;+let p20 = davisputnam+ <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w))+   ==> (exists x y. P(x) /\ Q(y)) ==> (exists z. R(z))>>;;+END_INTERACTIVE;;+-}++-- ------------------------------------------------------------------------- +-- Try to cut out useless instantiations in final result.                    +-- ------------------------------------------------------------------------- ++dp_refine :: (Literal lit atom, Atom atom term v, Term term v f) =>+             Set.Set (Set.Set lit) -> [v] -> Set.Set [term] -> Set.Set [term] -> Failing (Set.Set [term])+dp_refine cjs0 fvs dknow need =+    case Set.minView dknow of+      Nothing -> Success need+      Just (cl, dknow') ->+          let mfn = dp_mfn cjs0 . subst' . Map.fromList . zip fvs in+          dpll (Set.fold mfn Set.empty (Set.union need dknow')) >>= \ flag ->+          if flag then return (Set.insert cl need) else return need >>=+          dp_refine cjs0 fvs dknow'++dp_refine_loop :: forall lit atom term v f. (Literal lit atom, Term term v f, Atom atom term v) =>+                  Set.Set (Set.Set lit)+               -> Set.Set term+               -> Set.Set (f, Int)+               -> [v]+               -> Int+               -> Set.Set (Set.Set lit)+               -> Set.Set [term]+               -> Set.Set [term]+               -> Failing (Set.Set [term])+dp_refine_loop cjs0 cntms funcs fvs n cjs tried tuples =+    dp_loop cjs0 cntms funcs fvs n cjs tried tuples >>= \ tups ->+    dp_refine cjs0 fvs tups Set.empty++-- ------------------------------------------------------------------------- +-- Show how few of the instances we really need. Hence unification!          +-- ------------------------------------------------------------------------- ++davisputnam' :: forall fof atom term lit v f pf.+                (FirstOrderFormula fof atom v,+                 Literal lit atom,+                 PropositionalFormula pf atom, -- Formula pf atom,+                 Term term v f,+                 Atom atom term v,+                 IsString f) =>+                (atom -> Set.Set (f, Int)) -> fof -> Failing Int+davisputnam' fa fm =+    let (sfm :: pf) = runSkolem (skolemize id ((.~.)(generalize fm))) in+    let fvs = Set.toList (foldAtoms (\ s (a :: atom) -> Set.union (freeVariables a) s) Set.empty sfm)+        (consts,funcs) = herbfuns fa sfm in+    let cntms = Set.map (\ (c,_) -> fApp c []) consts in+    dp_refine_loop (simpcnf sfm :: Set.Set (Set.Set lit)) cntms funcs fvs 0 Set.empty Set.empty Set.empty >>= return . Set.size++{-+START_INTERACTIVE;;+let p36 = davisputnam'+ <<(forall x. exists y. P(x,y)) /\+   (forall x. exists y. G(x,y)) /\+   (forall x y. P(x,y) \/ G(x,y)+                ==> (forall z. P(y,z) \/ G(y,z) ==> H(x,z)))+   ==> (forall x. exists y. H(x,y))>>;;++let p29 = davisputnam'+ <<(exists x. P(x)) /\ (exists x. G(x)) ==>+   ((forall x. P(x) ==> H(x)) /\ (forall x. G(x) ==> J(x)) <=>+    (forall x y. P(x) /\ G(y) ==> H(x) /\ J(y)))>>;;+END_INTERACTIVE;;+-}
Data/Logic/Harrison/Lib.hs view
@@ -17,11 +17,16 @@     , exists     , tryApplyD     , allpairs+    , distrib'     , image     , optimize     , minimize     , maximize+    , optimize'+    , minimize'+    , maximize'     , can+    , allsets     , allsubsets     , allnonemptysubsets     , mapfilter@@ -197,6 +202,9 @@ -- allpairs f xs ys = Set.fromList (concatMap (\ z -> map (f z) (Set.toList ys)) (Set.toList xs)) allpairs f xs ys = Set.fold (\ x zs -> Set.fold (\ y zs' -> Set.insert (f x y) zs') zs ys) Set.empty xs +distrib' :: Ord a => Set.Set (Set.Set a) -> Set.Set (Set.Set a) -> Set.Set (Set.Set a)+distrib' s1 s2 = allpairs (Set.union) s1 s2+ test01 :: Test test01 = TestCase $ assertEqual "itlist2" expected input     where input = allpairs (,) (Set.fromList [1,2,3]) (Set.fromList [4,5,6])@@ -351,16 +359,25 @@ -- 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))+optimize :: forall a b. (b -> b -> Bool) -> (a -> b) -> [a] -> Maybe a+optimize _ _ [] = Nothing+optimize ord f l = Just (fst (foldr1 (\ p@(_,y) p'@(_,y') -> if ord y y' then p else p') (map (\ x -> (x,f x)) l))) -maximize :: forall a b. Ord b => (a -> b) -> [a] -> a+maximize :: forall a b. Ord b => (a -> b) -> [a] -> Maybe a maximize f l = optimize (>) f l -minimize :: forall a b. Ord b => (a -> b) -> [a] -> a+minimize :: forall a b. Ord b => (a -> b) -> [a] -> Maybe a minimize f l = optimize (<) f l +optimize' :: forall a b. (b -> b -> Bool) -> (a -> b) -> Set.Set a -> Maybe a+optimize' ord f s = optimize ord f (Set.toList s)++maximize' :: forall a b. Ord b => (a -> b) -> Set.Set a -> Maybe a+maximize' f s = optimize' (>) f s++minimize' :: forall a b. Ord b => (a -> b) -> Set.Set a -> Maybe a+minimize' f s = optimize' (<) f s+ -- ------------------------------------------------------------------------- -- Set operations on ordered lists.                                          -- -------------------------------------------------------------------------@@ -449,17 +466,19 @@   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.                       *)-(* ------------------------------------------------------------------------- *)+-- ------------------------------------------------------------------------- +-- 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);;--}+-- allsets :: Ord a => Int -> Set.Set a -> Set.Set (Set.Set a)+allsets :: forall a b. (Num a, Eq a, Ord b) => a -> Set.Set b -> Set.Set (Set.Set b)+allsets 0 _ = Set.singleton Set.empty+allsets m l =+    case Set.minView l of+      Nothing -> Set.empty+      Just (h, t) -> Set.union (Set.map (Set.insert h) (allsets (m - 1) t)) (allsets m t)  allsubsets :: forall a. Ord a => Set.Set a -> Set.Set (Set.Set a) allsubsets s =
Data/Logic/Harrison/Meson.hs view
@@ -5,11 +5,12 @@ import Control.Applicative.Error (Failing(..)) import qualified Data.Map as Map import qualified Data.Set as Set+import Data.Logic.Classes.Atom (Atom) import Data.Logic.Classes.Constants (Constants, false) import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..))-import Data.Logic.Classes.Formula (Formula)-import Data.Logic.Classes.Literal (Literal, fromLiteral)+import Data.Logic.Classes.Literal (Literal) import Data.Logic.Classes.Negate ((.~.), negative)+import Data.Logic.Classes.Propositional (PropositionalFormula) import Data.Logic.Classes.Term (Term) import Data.Logic.Harrison.FOL (generalize, list_conj) import Data.Logic.Harrison.Lib (setAll, settryfind)@@ -58,7 +59,7 @@ -- 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) =>+mexpand :: forall fof atom term v f. (FirstOrderFormula fof atom v, Literal fof atom, Term term v f, Atom atom term v, Ord fof) =>            Set.Set (Set.Set fof, fof)         -> Set.Set fof         -> fof@@ -85,7 +86,7 @@ -- 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) =>+puremeson :: forall fof atom term v f. (FirstOrderFormula fof atom v, Literal fof atom, Term term v f, Atom atom term v, Ord fof) =>              Maybe Int -> fof -> Failing ((Map.Map v term, Int, Int), Int) puremeson maxdl fm =     deepen f 0 maxdl@@ -94,11 +95,11 @@       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) =>+meson :: forall m fof atom term f v. (FirstOrderFormula fof atom v, PropositionalFormula fof atom, Literal fof atom, Term term v f, Atom atom term v, Ord fof, Monad m) =>          Maybe Int -> fof -> SkolemT v term m (Set.Set (Failing ((Map.Map v term, Int, Int), Int))) meson maxdl fm =     askolemize ((.~.)(generalize fm)) >>=-    return . Set.map (puremeson maxdl . list_conj) . simpdnf+    return . Set.map (puremeson maxdl . list_conj) . (simpdnf :: fof -> Set.Set (Set.Set fof))  {- -- -------------------------------------------------------------------------
Data/Logic/Harrison/Normal.hs view
@@ -9,15 +9,15 @@     , simpcnf'     ) where +import Control.Applicative.Error (failing) 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.Formula (Formula(atomic))+import Data.Logic.Classes.Literal (Literal, fromFirstOrder) 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 Data.Logic.Harrison.Skolem (nnf) import qualified Data.Set.Extra as Set import Prelude hiding (negate) @@ -66,7 +66,7 @@       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) =>+simpdnf' :: forall lit fof atom v. (FirstOrderFormula fof atom v, Literal lit atom, Formula lit atom, Ord lit) =>             fof -> Set.Set (Set.Set lit) simpdnf' fm =     foldFirstOrder qu co tf at fm@@ -75,12 +75,12 @@       co _ = def       tf False = Set.empty       tf True = Set.singleton Set.empty-      at = Set.singleton . Set.singleton . Data.Logic.Classes.Literal.atomic+      at = Set.singleton . Set.singleton . atomic       def = Set.filter keep djs       keep x = not (setAny (`Set.isProperSubsetOf` x) djs)       djs = Set.filter (not . trivial) (purednf' (nnf fm)) -purednf' :: forall lit fof atom v. (FirstOrderFormula fof atom v, Literal lit atom v, Ord lit) =>+purednf' :: forall lit fof atom v. (FirstOrderFormula fof atom v, Literal lit atom, Ord lit) =>             fof -> Set.Set (Set.Set lit) purednf' fm =     foldFirstOrder (\ _ _ _ -> x) co (\ _ -> x) (\ _ -> x)  fm@@ -90,7 +90,7 @@       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)+      x = failing (const (error "purednf'")) (Set.singleton . Set.singleton) (fromFirstOrder id fm)  -- -------------------------------------------------------------------------  -- Conjunctive normal form (CNF) by essentially the same code.               @@ -110,7 +110,7 @@       co _ = def       tf False = Set.singleton Set.empty       tf True = Set.empty-      at x = Set.singleton (Set.singleton (Data.Logic.Classes.FirstOrder.atomic x))+      at x = Set.singleton (Set.singleton (atomic x))       -- Discard any clause that is the proper subset of another clause       def = Set.filter keep cjs       keep x = not (setAny (`Set.isProperSubsetOf` x) cjs)@@ -121,12 +121,12 @@  -- 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' :: forall lit fof atom v. (FirstOrderFormula fof atom v, Literal lit atom, Ord lit) => fof -> Set.Set (Set.Set lit) simpcnf' fm =     foldFirstOrder (\ _ _ _ -> cjs') co tf at fm     where       co _ = cjs'-      at = Set.singleton . Set.singleton . Data.Logic.Classes.Literal.atomic -- foldAtomEq (\ _ _ -> cjs') tf (\ _ _ -> cjs')+      at = Set.singleton . Set.singleton . atomic -- foldAtomEq (\ _ _ -> cjs') tf (\ _ _ -> cjs')       tf False = Set.singleton Set.empty       tf True = Set.empty       -- Discard any clause that is the proper subset of another clause@@ -135,5 +135,5 @@       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' :: forall lit fof atom v. (FirstOrderFormula fof atom v, Literal lit atom, Ord lit) => fof -> Set.Set (Set.Set lit) purecnf' fm = Set.map (Set.map (.~.)) (purednf' (nnf ((.~.) fm)))
Data/Logic/Harrison/Prolog.hs view
@@ -2,8 +2,8 @@ {-# OPTIONS_GHC -Wall #-} module Data.Logic.Harrison.Prolog where +import Data.Logic.Classes.Atom (Atom) import Data.Logic.Classes.FirstOrder (FirstOrderFormula)-import Data.Logic.Classes.Formula (Formula) import Data.Logic.Classes.Term (Term(vt)) import Data.String (IsString (fromString)) import Data.Logic.Harrison.FOL (fv, subst, list_conj)@@ -18,7 +18,7 @@ -- Rename a rule.                                                             -- -------------------------------------------------------------------------  -renamerule :: forall fof atom term v f. (FirstOrderFormula fof atom v, Formula atom term v, Term term v f, Ord fof) =>+renamerule :: forall fof atom term v f. (FirstOrderFormula fof atom v, {-Formula fof term v,-} Atom atom term v, Term term v f, Ord fof) =>               Int -> (Set.Set fof, fof) -> ((Set.Set fof, fof), Int) renamerule k (asm,c) =     ((Set.map inst asm, inst c), k + Set.size fvs)
Data/Logic/Harrison/Prop.hs view
@@ -4,6 +4,8 @@     ( eval     , atoms     , onAllValuations+    , TruthTable+    , TruthTableRow     , truthTable     , tautology     , unsatisfiable@@ -11,10 +13,11 @@     , rawdnf     , purednf     , dnf+    , dnf'     , trivial     , psimplify     , nnf-    -- , simpdnf+    , simpdnf     , simpcnf     , positive     , negative@@ -30,18 +33,27 @@     , allSatValuations     , dnf0     , cnf+    , 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.Constants (Constants(fromBool, asBool), true, false, ifElse)+import Data.Logic.Classes.Formula (Formula(atomic))+import Data.Logic.Classes.Literal (Literal(foldLiteral), toPropositional) import Data.Logic.Classes.Negate ((.~.)) import Data.Logic.Classes.Propositional import Data.Logic.Harrison.Formulas.Propositional (atom_union, on_atoms)-import Data.Logic.Harrison.Lib (fpf, allpairs, setAny)+import Data.Logic.Harrison.Lib (fpf, setAny, distrib') import qualified Data.Map as Map import qualified Data.Set as Set import Prelude hiding (negate) +-- type Map a = Map.Map a Bool+-- m0 = Map.empty+-- ins :: forall a. Ord a => a -> Bool -> Map a -> Map a+-- ins = Map.insert+-- m ! k = Map.findWithDefault False k m+ -- -------------------------------------------------------------------------  -- Parsing of propositional formulas.                                         -- ------------------------------------------------------------------------- @@ -80,7 +92,7 @@ -- Interpretation of formulas.                                                -- -------------------------------------------------------------------------  -eval :: PropositionalFormula formula atomic => formula -> (atomic -> Bool) -> Bool+eval :: (PropositionalFormula formula atomic, Ord atomic) => formula -> Map.Map atomic Bool -> Bool eval fm v =     foldPropositional co id at fm     where@@ -89,7 +101,7 @@       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+      at x = Map.findWithDefault False x v  {- START_INTERACTIVE;;@@ -112,30 +124,34 @@ -- 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+onAllValuations :: (Ord a) =>+                   (r -> r -> r)         -- ^ Combine function for result type+                -> (Map.Map a Bool -> r) -- ^ The substitution function+                -> Map.Map a Bool        -- ^ The default valuation function for atoms not in ps+                -> Set.Set a             -- ^ The variables to vary                 -> r onAllValuations _ subfn v ps | Set.null ps = subfn v onAllValuations append subfn v ps =-    case Set.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')+    case Set.minView ps of+      Nothing -> error "onAllValuations"+      Just (p, ps') ->+          append -- Do the valuations of the remaining variables with  set to false+                 (onAllValuations append subfn (Map.insert p False v) ps')+                 -- Do the valuations of the remaining variables with  set to true+                 (onAllValuations append subfn (Map.insert p True v) ps') -type TruthTableRow a = ([(a, Bool)], Bool)+type TruthTableRow = ([Bool], Bool)+type TruthTable a = ([a], [TruthTableRow]) -truthTable :: forall formula atomic. (PropositionalFormula formula atomic, Eq atomic, Ord atomic) =>-              formula -> [TruthTableRow atomic]+truthTable :: forall formula atom. (PropositionalFormula formula atom, Eq atom, Ord atom) =>+              formula -> TruthTable atom truthTable fm =-    onAllValuations (++) mkRow (const False) ats+    (atl, onAllValuations (++) mkRow Map.empty 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)]+      mkRow :: Map.Map atom Bool      -- ^ The current variable assignment+            -> [TruthTableRow]          -- ^ The variable assignments and the formula value+      mkRow v = [(map (\ k -> Map.findWithDefault False k v) atl, eval fm v)]+      atl = Set.toAscList ats       ats = atoms fm  -- ------------------------------------------------------------------------- @@ -143,7 +159,7 @@ -- -------------------------------------------------------------------------   tautology :: (PropositionalFormula formula atomic, Ord atomic) => formula -> Bool-tautology fm = onAllValuations (&&) (eval fm) (const False) (atoms fm)+tautology fm = onAllValuations (&&) (eval fm) Map.empty (atoms fm)  -- -------------------------------------------------------------------------  -- Related concepts.                                                         @@ -222,16 +238,15 @@ -- Some operations on literals.                                               -- -------------------------------------------------------------------------  -negative :: PropositionalFormula formula atomic => formula -> Bool+negative :: forall lit atom. Literal lit atom => lit -> Bool negative lit =-    foldPropositional c tf a lit+    foldLiteral neg tf a lit     where-      c ((:~:) _) = True-      c _ = False+      neg _ = True       tf = not       a _ = False -positive :: PropositionalFormula formula atomic => formula -> Bool+positive :: Literal lit atom => lit -> Bool positive = not . negative  negate :: PropositionalFormula formula atomic => formula -> formula@@ -277,7 +292,7 @@     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       nenfCombine (BinOp p (:<=>:) q) = nenf' p .<=>. nenf' q@@ -290,6 +305,20 @@ nenf :: (PropositionalFormula formula atomic, Eq formula) => formula -> formula nenf = nenf' . psimplify +{-+# Not (prime 2) ->+  <<~(~(((out_0 <=> x_0 /\ y_0) /\ ~out_1) /\ ~out_0 /\ out_1))>>++# nenf (Not (prime 2)) -> +  <<((out_0 <=> x_0 /\ y_0) /\ ~out_1) /\ ~out_0 /\ out_1>>++> pretty ((.~.)(prime 2 :: Formula (Data.Logic.Harrison.PropExamples.Atom N)))+     (out0 ⇔ x0 ∧ y0) ∧ ¬out1 ∧ out1 ∧ ¬out0++> pretty (nenf ((.~.)(prime 2 :: Formula (Data.Logic.Harrison.PropExamples.Atom N))))+     (out0 ⇔ x0 ∨ y0) ∨ ¬out1 ∨ out1 ∨ ¬out0+-}+ -- -------------------------------------------------------------------------  -- Disjunctive normal form (DNF) via truth tables.                            -- ------------------------------------------------------------------------- @@ -300,22 +329,22 @@ 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 :: (PropositionalFormula formula atomic, Ord formula, Ord atomic) =>+          Set.Set formula -> Map.Map atomic Bool -> formula mkLits pvs v = list_conj (Set.map (\ p -> if eval p v then p else (.~.) p) pvs) -allSatValuations :: Eq a => ((a -> Bool) -> Bool) -> (a -> Bool) -> Set.Set a -> [a -> Bool]+allSatValuations :: Ord a => (Map.Map a Bool -> Bool) -> Map.Map a Bool -> Set.Set a -> [Map.Map a Bool] allSatValuations subfn v pvs =     case Set.minView pvs of       Nothing -> if subfn v then [v] else []-      Just (p, ps) -> (allSatValuations subfn (\ q -> if q == p then False else v p) ps) ++-                      (allSatValuations subfn (\ q -> if q == p then True else v p) ps)+      Just (p, ps) -> (allSatValuations subfn (Map.insert p False v) ps) +++                      (allSatValuations subfn (Map.insert p True v) ps)  dnf0 :: forall formula atomic. (PropositionalFormula formula atomic, Ord atomic, Ord formula) => formula -> formula dnf0 fm =     list_disj (Set.fromList (map (mkLits (Set.map atomic pvs)) satvals))     where-      satvals = allSatValuations (eval fm) (const False) pvs+      satvals = allSatValuations (eval fm) Map.empty pvs       pvs = atoms fm  -- ------------------------------------------------------------------------- @@ -351,24 +380,22 @@ -- 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 :: (PropositionalFormula pf atom, Literal lit atom, Ord lit) => pf -> Set.Set (Set.Set lit) purednf fm =     foldPropositional c tf a fm     where       c (BinOp p (:&:) q) = distrib' (purednf p) (purednf q)       c (BinOp p (:|:) q) = Set.union (purednf p) (purednf q)-      c _ = Set.singleton (Set.singleton fm)-      tf _ = Set.singleton (Set.singleton fm)-      a _ = Set.singleton (Set.singleton fm)+      c ((:~:) p) = Set.map (Set.map (.~.)) (purednf p)+      c _ = error "purednf" -- Set.singleton (Set.singleton fm)+      tf x = Set.singleton (Set.singleton (fromBool x))+      a x = Set.singleton (Set.singleton (atomic x))  -- -------------------------------------------------------------------------  -- Filtering out trivial disjuncts (in this guise, contradictory).            -- -------------------------------------------------------------------------  -trivial :: (PropositionalFormula formula atomic, Ord formula) => Set.Set formula -> Bool+trivial :: (Literal lit atom, Ord lit) => Set.Set lit -> Bool trivial lits =     not . Set.null $ Set.intersection neg (Set.map (.~.) pos)     where (pos, neg) = Set.partition positive lits@@ -377,33 +404,35 @@ -- 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 :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, Ord lit) => pf -> Set.Set (Set.Set lit) simpdnf fm =     foldPropositional c tf a fm     where-      c :: Combination formula -> Set.Set (Set.Set formula)+      c :: Combination pf -> Set.Set (Set.Set lit)       c _ = Set.filter (\ d -> not (setAny (\ d' -> Set.isProperSubsetOf d' d) djs)) djs           where djs = Set.filter (not . trivial) (purednf (nnf fm))       tf = ifElse (Set.singleton Set.empty) Set.empty-      a :: atomic -> Set.Set (Set.Set formula)-      a _ = Set.singleton (Set.singleton fm)+      a :: atom -> Set.Set (Set.Set lit)+      a x = Set.singleton (Set.singleton (atomic x))  -- -------------------------------------------------------------------------  -- Mapping back to a formula.                                                 -- -------------------------------------------------------------------------  -dnf :: (PropositionalFormula formula atomic, Ord formula) => formula -> formula-dnf fm = list_disj (Set.map list_conj (simpdnf fm))+dnf :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, Ord lit) => Set.Set (Set.Set lit) -> pf+dnf = list_disj . Set.map (list_conj . Set.map (toPropositional id)) +dnf' :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom) => pf -> pf+dnf' = dnf . (simpdnf :: pf -> Set.Set (Set.Set pf))+ -- -------------------------------------------------------------------------  -- Conjunctive normal form (CNF) by essentially the same code.                -- -------------------------------------------------------------------------  -purecnf :: (PropositionalFormula formula atomic, Ord formula) => formula -> Set.Set (Set.Set formula)-purecnf fm = Set.map (Set.map (psimplify . (.~.))) (purednf (nnf ((.~.) fm)))+purecnf :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, Ord lit) => pf -> Set.Set (Set.Set lit)+purecnf fm = Set.map (Set.map (.~.)) (purednf (nnf ((.~.) fm))) -simpcnf :: (PropositionalFormula formula atomic, Ord formula) =>-           formula -> Set.Set (Set.Set formula)+simpcnf :: (PropositionalFormula pf atom, Literal lit atom, Ord lit) => pf -> Set.Set (Set.Set lit) simpcnf fm =     foldPropositional c tf a fm     where@@ -412,7 +441,10 @@       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)+      a x = Set.singleton (Set.singleton (atomic x)) -cnf :: (PropositionalFormula formula atomic, Ord formula) => formula -> formula-cnf fm = list_conj (Set.map list_disj (simpcnf fm))+cnf :: forall pf lit atom. (PropositionalFormula pf atom, Literal lit atom, Ord lit) => Set.Set (Set.Set lit) -> pf+cnf = list_conj . Set.map (list_disj . Set.map (toPropositional id))++cnf' :: forall pf atom. (PropositionalFormula pf atom, Literal pf atom) => pf -> pf+cnf' = cnf . (simpcnf :: pf -> Set.Set (Set.Set pf))
+ Data/Logic/Harrison/PropExamples.hs view
@@ -0,0 +1,392 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeSynonymInstances #-}+module Data.Logic.Harrison.PropExamples+    ( Atom(..)+    , N+    , prime+    , ramsey+    , tests+    ) where++import Data.Bits (Bits, shiftR)+import Data.Logic.Classes.Combine ((.<=>.), (.=>.), (.&.), (.|.), Combinable, Combination(..), BinOp(..))+import Data.Logic.Classes.Constants (true, false)+import qualified Data.Logic.Classes.Formula as C+import Data.Logic.Classes.Negate ((.~.))+import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), botFixity)+import Data.Logic.Classes.Propositional (PropositionalFormula(..))+import Data.Logic.Harrison.Lib (allsets)+import Data.Logic.Harrison.Prop (tautology, list_conj, list_disj, psimplify)+import Data.Logic.Types.Propositional (Formula(..))+import qualified Data.Set as Set+import Prelude hiding (sum)+import Test.HUnit+import Text.PrettyPrint (text)++tests :: Test+tests = TestList [test01, test02, test03]++-- ========================================================================= +-- Some propositional formulas to test, and functions to generate classes.   +--                                                                           +-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)  +-- ========================================================================= ++-- ------------------------------------------------------------------------- +-- Generate assertion equivalent to R(s,t) <= n for the Ramsey number R(s,t) +-- ------------------------------------------------------------------------- ++data Atom a = P String a (Maybe a) deriving (Eq, Ord, Show)++instance Pretty (Atom N) where+    pretty (P s n mm) = text (s ++ show n ++ maybe "" (\ m -> "." ++ show m) mm)++instance HasFixity (Atom N) where+    fixity = const botFixity++type N = Int++ramsey :: forall formula.+          (PropositionalFormula formula (Atom N), Ord formula) =>+          Int -> Int -> N -> formula+ramsey s t n =+  let vertices = Set.fromList [1 .. n] in+  let yesgrps = Set.map (allsets (2 :: Int)) (allsets s vertices)+      nogrps = Set.map (allsets (2 :: Int)) (allsets t vertices) in+  let e xs = let [m, n] = Set.toAscList xs in C.atomic (P "p" m (Just n)) in+  list_disj (Set.map (list_conj . Set.map e) yesgrps) .|. list_disj (Set.map (list_conj . Set.map (\ p -> (.~.)(e p))) nogrps)++-- ------------------------------------------------------------------------- +-- Some currently tractable examples.                                        +-- ------------------------------------------------------------------------- ++test01 :: Test+test01 = TestList [{- TestCase (assertEqual "ramsey 3 3 4"+                                             (Combine+                                              (BinOp+                                               (Combine+                                                (BinOp+                                                 (Combine+                                                  (BinOp+                                                   (Atom (P "p" 1 (Just 4)))+                                                   (:&:)+                                                   (Combine+                                                    (BinOp+                                                     (Atom (P "p" 2 (Just 4)))+                                                     (:&:)+                                                     (Atom (P "p" 1 (Just 2)))))))+                                                 (:|:)+                                                 (Combine+                                                  (BinOp+                                                   (Combine+                                                    (BinOp+                                                     (Atom (P "p" 1 (Just 4)))+                                                     (:&:)+                                                     (Combine+                                                      (BinOp+                                                       (Atom (P "p" 3 (Just 4)))+                                                       (:&:)+                                                       (Atom (P "p" 1 (Just 3)))))))+                                                   (:|:)+                                                   (Combine+                                                    (BinOp+                                                     (Combine+                                                      (BinOp+                                                       (Atom (P "p" 2 (Just 4)))+                                                       (:&:)+                                                       (Combine+                                                        (BinOp+                                                         (Atom (P "p" 3 (Just 4)))+                                                         (:&:)+                                                         (Atom (P "p" 2 (Just 3)))))))+                                                     (:|:)+                                                     (Combine+                                                      (BinOp+                                                       (Atom (P "p" 1 (Just 3)))+                                                       (:&:)+                                                       (Combine+                                                        (BinOp+                                                         (Atom (P "p" 2 (Just 3)))+                                                         (:&:)+                                                         (Atom (P "p" 1 (Just 2)))))))))))))+                                               (:|:)+                                               (Combine+                                                (BinOp+                                                 (Combine+                                                  (BinOp (Combine+                                                          ((:~:) (Atom (P "p" 1 (Just 4))))) (:&:)+                                                   (Combine+                                                    (BinOp+                                                     (Combine+                                                      ((:~:) (Atom (P "p" 2 (Just 4)))))+                                                     (:&:)+                                                     (Combine+                                                      ((:~:) (Atom (P "p" 1 (Just 2)))))))))+                                                 (:|:)+                                                 (Combine+                                                  (BinOp+                                                   (Combine+                                                    (BinOp (Combine+                                                            ((:~:) (Atom (P "p" 1 (Just 4)))))+                                                     (:&:)+                                                     (Combine+                                                      (BinOp+                                                       (Combine+                                                        ((:~:) (Atom (P "p" 3 (Just 4)))))+                                                       (:&:)+                                                       (Combine+                                                        ((:~:) (Atom (P "p" 1 (Just 3)))))))))+                                                   (:|:)+                                                   (Combine+                                                    (BinOp+                                                     (Combine+                                                      (BinOp+                                                       (Combine+                                                        ((:~:) (Atom (P "p" 2 (Just 4)))))+                                                       (:&:)+                                                       (Combine+                                                        (BinOp+                                                         (Combine+                                                          ((:~:) (Atom (P "p" 3 (Just 4)))))+                                                         (:&:)+                                                         (Combine+                                                          ((:~:) (Atom (P "p" 2 (Just 3)))))))))+                                                     (:|:)+                                                     (Combine+                                                      (BinOp+                                                       (Combine+                                                        ((:~:) (Atom (P "p" 1 (Just 3)))))+                                                       (:&:)+                                                       (Combine+                                                        (BinOp+                                                         (Combine+                                                          ((:~:) (Atom (P "p" 2 (Just 3)))))+                                                         (:&:)+                                                         (Combine+                                                          ((:~:) (Atom (P "p" 1 (Just 2)))))))))))))))))+                                         (ramsey 3 3 4 :: Formula (Atom N))), -}+                   TestCase (assertEqual "tautology (ramsey 3 3 5)" False (tautology (ramsey 3 3 5 :: Formula (Atom N)))),+                   TestCase (assertEqual "tautology (ramsey 3 3 6)" True (tautology (ramsey 3 3 6 :: Formula (Atom N))))]++-- ------------------------------------------------------------------------- +-- Half adder.                                                               +-- ------------------------------------------------------------------------- ++halfsum :: forall formula. Combinable formula => formula -> formula -> formula+halfsum x y = x .<=>. ((.~.) y)++halfcarry :: forall formula. Combinable formula => formula -> formula -> formula+halfcarry x y = x .&. y++ha :: forall formula. Combinable formula => formula -> formula -> formula -> formula -> formula+ha x y s c = (s .<=>. halfsum x y) .&. (c .<=>. halfcarry x y)++-- ------------------------------------------------------------------------- +-- Full adder.                                                               +-- ------------------------------------------------------------------------- ++carry :: forall formula. Combinable formula => formula -> formula -> formula -> formula+carry x y z = (x .&. y) .|. ((x .|. y) .&. z)++sum :: forall formula. Combinable formula => formula -> formula -> formula -> formula+sum x y z = halfsum (halfsum x y) z++fa :: forall formula. Combinable formula => formula -> formula -> formula -> formula -> formula -> formula+fa x y z s c = (s .<=>. sum x y z) .&. (c .<=>. carry x y z)++-- ------------------------------------------------------------------------- +-- Useful idiom.                                                             +-- ------------------------------------------------------------------------- ++conjoin :: forall formula atomic a. (PropositionalFormula formula atomic, Ord formula, Ord a) => (a -> formula) -> Set.Set a -> formula+conjoin f l = list_conj (Set.map f l)++-- ------------------------------------------------------------------------- +-- n-bit ripple carry adder with carry c(0) propagated in and c(n) out.      +-- ------------------------------------------------------------------------- ++ripplecarry :: forall formula atomic a. (PropositionalFormula formula atomic, Ord a, Ord formula, Num a, Enum a) =>+               (a -> formula)+            -> (a -> formula)+            -> (a -> formula)+            -> (a -> formula)+            -> a -> formula+ripplecarry x y c out n =+    conjoin (\ i -> fa (x i) (y i) (c i) (out i) (c(i + 1))) (Set.fromList [0 .. (n - 1)])++-- ------------------------------------------------------------------------- +-- Example.                                                                  +-- ------------------------------------------------------------------------- ++mk_index :: forall formula a. PropositionalFormula formula (Atom a) => String -> a -> formula+mk_index x i = C.atomic (P x i Nothing)+mk_index2 :: forall formula a. PropositionalFormula formula (Atom a) => String -> a -> a -> formula+mk_index2 x i j = C.atomic (P x i (Just j))++test02 = TestCase (assertEqual "ripplecarry x y c out 2"+                               (Combine (BinOp (Combine (BinOp (Combine (BinOp (Atom (P "OUT" 1 Nothing)) (:<=>:) (Combine (BinOp (Combine (BinOp (Atom (P "X" 1 Nothing)) (:<=>:) (Combine ((:~:) (Atom (P "Y" 1 Nothing)))))) (:<=>:) (Combine ((:~:) (Atom (P "C" 1 Nothing)))))))) (:&:)+                                                         (Combine (BinOp (Atom (P "C" 2 Nothing)) (:<=>:) (Combine (BinOp (Combine (BinOp (Atom (P "X" 1 Nothing)) (:&:) (Atom (P "Y" 1 Nothing)))) (:|:) (Combine (BinOp (Combine (BinOp (Atom (P "X" 1 Nothing)) (:|:) (Atom (P "Y" 1 Nothing)))) (:&:) (Atom (P "C" 1 Nothing)))))))))) (:&:)+                                         (Combine (BinOp (Combine (BinOp (Atom (P "OUT" 0 Nothing)) (:<=>:) (Combine (BinOp (Combine (BinOp (Atom (P "X" 0 Nothing)) (:<=>:) (Combine ((:~:) (Atom (P "Y" 0 Nothing)))))) (:<=>:) (Combine ((:~:) (Atom (P "C" 0 Nothing)))))))) (:&:)+                                                   (Combine (BinOp (Atom (P "C" 1 Nothing)) (:<=>:) (Combine (BinOp (Combine (BinOp (Atom (P "X" 0 Nothing)) (:&:) (Atom (P "Y" 0 Nothing)))) (:|:) (Combine (BinOp (Combine (BinOp (Atom (P "X" 0 Nothing)) (:|:) (Atom (P "Y" 0 Nothing)))) (:&:) (Atom (P "C" 0 Nothing))))))))))))+                               {- <<((OUT_0 <=> (X_0 <=> ~Y_0) <=> ~C_0) /\+                                      (C_1 <=> X_0 /\ Y_0 \/ (X_0 \/ Y_0) /\ C_0)) /\+                                     (OUT_1 <=> (X_1 <=> ~Y_1) <=> ~C_1) /\+                                     (C_2 <=> X_1 /\ Y_1 \/ (X_1 \/ Y_1) /\ C_1)>> -}+                               (let [x, y, out, c] = map mk_index ["X", "Y", "OUT", "C"] in+                                ripplecarry x y c out 2 :: Formula (Atom N)))++-- ------------------------------------------------------------------------- +-- Special case with 0 instead of c(0).                                      +-- ------------------------------------------------------------------------- ++ripplecarry0 :: forall formula atomic a. (PropositionalFormula formula atomic, Ord formula, Ord a, Num a, Enum a) =>+                (a -> formula)+             -> (a -> formula)+             -> (a -> formula)+             -> (a -> formula)+             -> a -> formula+ripplecarry0 x y c out n =+  psimplify+   (ripplecarry x y (\ i -> if i == 0 then false else c i) out n)++-- ------------------------------------------------------------------------- +-- Carry-select adder                                                        +-- ------------------------------------------------------------------------- ++ripplecarry1 :: forall formula atomic a. (PropositionalFormula formula atomic, Ord formula, Ord a, Num a, Enum a) =>+                (a -> formula)+             -> (a -> formula)+             -> (a -> formula)+             -> (a -> formula)+             -> a -> formula+ripplecarry1 x y c out n =+  psimplify+   (ripplecarry x y (\ i -> if i == 0 then true else c i) out n)++mux :: forall formula. Combinable formula => formula -> formula -> formula -> formula+mux sel in0 in1 = (((.~.) sel) .&. in0) .|. (sel .&. in1)++offset :: forall t a. Num a => a -> (a -> t) -> a -> t+offset n x i = x (n + i)++carryselect :: forall formula atomic a. (PropositionalFormula formula atomic, Ord a, Ord formula, Num a, Enum a) =>+               (a -> formula)+            -> (a -> formula)+            -> (a -> formula)+            -> (a -> formula)+            -> (a -> formula)+            -> (a -> formula)+            -> (a -> formula)+            -> (a -> formula)+            -> a -> a -> formula+carryselect x y c0 c1 s0 s1 c s n k =+  let k' = min n k in+  let fm = ((ripplecarry0 x y c0 s0 k') .&. (ripplecarry1 x y c1 s1 k')) .&.+           (((c k') .<=>. (mux (c 0) (c0 k') (c1 k'))) .&.+            (conjoin (\ i -> (s i) .<=>. (mux (c 0) (s0 i) (s1 i)))+                             (Set.fromList [0 .. (k' - 1)]))) in+  if k' < k then fm else+  fm .&. (carryselect+          (offset k x) (offset k y) (offset k c0) (offset k c1)+          (offset k s0) (offset k s1) (offset k c) (offset k s)+          (n - k) k)++-- ------------------------------------------------------------------------- +-- Equivalence problems for carry-select vs ripple carry adders.             +-- ------------------------------------------------------------------------- ++mk_adder_test :: forall formula a. (PropositionalFormula formula (Atom a), Ord a, Ord formula, Num a, Enum a) =>+                 a -> a -> formula+mk_adder_test n k =+  let [x, y, c, s, c0, s0, c1, s1, c2, s2] =+          map mk_index ["x", "y", "c", "s", "c0", "s0", "c1", "s1", "c2", "s2"] in+  (((carryselect x y c0 c1 s0 s1 c s n k) .&.+    ((.~.) (c 0))) .&.+   (ripplecarry0 x y c2 s2 n)) .=>.+  (((c n) .<=>. (c2 n)) .&.+   (conjoin (\ i -> (s i) .<=>. (s2 i)) (Set.fromList [0 .. (n - 1)])))++-- ------------------------------------------------------------------------- +-- Ripple carry stage that separates off the final result.                   +--                                                                           +--       UUUUUUUUUUUUUUUUUUUU  (u)                                           +--    +  VVVVVVVVVVVVVVVVVVVV  (v)                                           +--                                                                           +--    = WWWWWWWWWWWWWWWWWWWW   (w)                                           +--    +                     Z  (z)                                           +-- ------------------------------------------------------------------------- ++rippleshift :: forall formula atomic a. (PropositionalFormula formula atomic, Ord a, Ord formula, Num a, Enum a) =>+               (a -> formula)+            -> (a -> formula)+            -> (a -> formula)+            -> formula+            -> (a -> formula)+            -> a -> formula+rippleshift u v c z w n =+  ripplecarry0 u v (\ i -> if i == n then w(n - 1) else c(i + 1))+                   (\ i -> if i == 0 then z else w(i - 1)) n+-- ------------------------------------------------------------------------- +-- Naive multiplier based on repeated ripple carry.                          +-- ------------------------------------------------------------------------- ++multiplier :: forall formula atomic a. (PropositionalFormula formula atomic, Ord a, Ord formula, Num a, Enum a) =>+              (a -> a -> formula)+           -> (a -> a -> formula)+           -> (a -> a -> formula)+           -> (a -> formula)+           -> a+           -> formula+multiplier x u v out n =+  if n == 1 then ((out 0) .<=>. (x 0 0)) .&. ((.~.)(out 1)) else+  psimplify (((out 0) .<=>. (x 0 0)) .&.+             ((rippleshift+               (\ i -> if i == n - 1 then false else x 0 (i + 1))+               (x 1) (v 2) (out 1) (u 2) n) .&.+              (if n == 2 then ((out 2) .<=>. (u 2 0)) .&. ((out 3) .<=>. (u 2 1)) else+                   conjoin (\ k -> rippleshift (u k) (x k) (v(k + 1)) (out k)+                                   (if k == n - 1 then \ i -> out(n + i)+                                    else u(k + 1)) n) (Set.fromList [2 .. (n - 1)]))))++-- ------------------------------------------------------------------------- +-- Primality examples.                                                       +-- For large examples, should use "num" instead of "int" in these functions. +-- ------------------------------------------------------------------------- ++bitlength :: forall b a. (Bits b, Num a) => b -> a+bitlength x = if x == 0 then 0 else 1 + bitlength (shiftR x 1);;++bit :: forall a b. (Num a, Eq a, Bits b, Integral b) => a -> b -> Bool+bit n x = if n == 0 then x `mod` 2 == 1 else bit (n - 1) (shiftR x 1)++congruent_to :: forall formula atomic a b. (Bits b, PropositionalFormula formula atomic, Ord a, Ord formula, Num a, Integral b, Enum a) =>+                (a -> formula) -> b -> a -> formula+congruent_to x m n =+  conjoin (\ i -> if bit i m then x i else (.~.)(x i))+          (Set.fromList [0 .. (n - 1)])++prime :: forall formula. (PropositionalFormula formula (Atom N), Ord formula) => N -> formula+prime p =+  let [x, y, out] = map mk_index ["x", "y", "out"] in+  let m i j = (x i) .&. (y j)+      [u, v] = map mk_index2 ["u", "v"] in+  let (n :: Int) = bitlength p in+  (.~.) (multiplier m u v out (n - 1) .&. congruent_to out p (max n (2 * n - 2)))++-- ------------------------------------------------------------------------- +-- Examples.                                                                 +-- ------------------------------------------------------------------------- ++type F = Formula (Atom Int)++deriving instance Show F++{-+instance Constants F where+    fromBool True = +-}++test03 :: Test+test03 =+    TestList [TestCase (assertEqual "tautology(prime 7)" True (tautology(prime 7 :: F))),+              TestCase (assertEqual "tautology(prime 9)" False (tautology(prime 9 :: F))),+              TestCase (assertEqual "tautology(prime 11)" True (tautology(prime 11 :: F)))]
Data/Logic/Harrison/Resolution.hs view
@@ -1,14 +1,21 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-}-module Data.Logic.Harrison.Resolution where+module Data.Logic.Harrison.Resolution+    ( resolution1+    , resolution2+    , resolution3+    , presolution+    , matchAtomsEq+    ) where  import Control.Applicative.Error (Failing(..), failing)+import Data.Logic.Classes.Atom (Atom(match)) import Data.Logic.Classes.Combine (Combination(..)) import Data.Logic.Classes.Equals (AtomEq, zipAtomsEq) import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), zipFirstOrder)-import Data.Logic.Classes.Formula (Formula(match)) import Data.Logic.Classes.Literal (Literal) import Data.Logic.Classes.Negate ((.~.), positive)+import Data.Logic.Classes.Propositional (PropositionalFormula) import Data.Logic.Classes.Term (Term(vt, foldTerm)) import Data.Logic.Classes.Variable (Variable(prefix)) import Data.Logic.Harrison.FOL (subst, fv, generalize, list_disj, list_conj)@@ -32,7 +39,7 @@ -- 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) =>+mgu :: forall lit atom term v f. (Literal lit atom, Term term v f, Atom atom term v) =>        Set.Set lit -> Map.Map v term -> Failing (Map.Map v term) mgu l env =     case Set.minView l of@@ -42,7 +49,7 @@             _ -> Success (solve env)       _ -> Success (solve env) -unifiable :: (Literal lit atom v, Term term v f, Formula atom term v) =>+unifiable :: (Literal lit atom, Term term v f, Atom atom term v) =>              lit -> lit -> Bool unifiable p q = failing (const False) (const True) (unify_literals Map.empty p q) @@ -50,7 +57,7 @@ -- Rename a clause.                                                           -- -------------------------------------------------------------------------  -rename :: (FirstOrderFormula fof atom v, Term term v f, Formula atom term v, Ord fof) =>+rename :: (FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) =>           (v -> v) -> Set.Set fof -> Set.Set fof rename pfx cls =     Set.map (subst (Map.fromList (zip fvs vvs))) cls@@ -64,7 +71,7 @@ -- 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) =>+resolvents :: (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) =>               Set.Set fof -> Set.Set fof -> fof -> Set.Set fof -> Set.Set fof resolvents cl1 cl2 p acc =     if Set.null ps2 then acc else Set.fold doPair acc pairs@@ -81,7 +88,7 @@       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) =>+                   (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) =>                    Set.Set fof -> Set.Set fof -> Set.Set fof resolve_clauses cls1 cls2 =     let cls1' = rename (prefix "x") cls1@@ -92,37 +99,32 @@ -- 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 =+resloop1 :: forall atom v term f fof. (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) =>+            Set.Set (Set.Set fof) -> Set.Set (Set.Set fof) -> Failing Bool+resloop1 used unused =     maybe (Failure ["No proof found"]) step (Set.minView unused)     where       step (cl, ros) =-          if Set.member Set.empty news then return True else resloop1 ua used' (Set.union ros news)+          if Set.member Set.empty news then return True else resloop1 used' (Set.union ros news)           where             used' = Set.insert cl used             -- resolve_clauses is not in the Failing monad, so setmapfilter isn't appropriate.             news = Set.fold Set.insert Set.empty ({-setmapfilter-} Set.map (resolve_clauses cl) used') -pure_resolution1 :: forall fof atom v term f. (Literal fof atom 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)))+pure_resolution1 :: forall fof atom v term f. (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) =>+                    fof -> Failing Bool+pure_resolution1 fm = resloop1 Set.empty (simpcnf (specialize (pnf fm)))  resolution1 :: forall m fof term f atom v.-               (Literal fof atom v,+               (Literal fof atom,                 FirstOrderFormula fof atom v,+                PropositionalFormula fof atom,                 Term term v f,-                Formula atom term v,+                Atom 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+               fof -> SkolemT v term m (Set.Set (Failing Bool))+resolution1 fm = askolemize ((.~.)(generalize fm)) >>= return . Set.map (pure_resolution1 . list_conj) . (simpdnf :: fof -> Set.Set (Set.Set fof))  -- -------------------------------------------------------------------------  -- Matching of terms and literals.                                           @@ -157,7 +159,7 @@     _ -> Failure ["term_match"] -} -match_literals :: forall term f v fof atom. (FirstOrderFormula fof atom v, Formula atom term v, Term term v f) =>+match_literals :: forall term f v fof atom. (FirstOrderFormula fof atom v, Atom atom term v, Term term v f) =>                   Map.Map v term -> fof -> fof -> Failing (Map.Map v term) match_literals env t1 t2 =     fromMaybe err (zipFirstOrder qu co tf at t1 t2)@@ -195,7 +197,7 @@ -- Test for subsumption                                                       -- -------------------------------------------------------------------------  -subsumes_clause :: forall term f v fof atom. (FirstOrderFormula fof atom v, Term term v f, Formula atom term v) =>+subsumes_clause :: forall term f v fof atom. (FirstOrderFormula fof atom v, Term term v f, Atom atom term v) =>                    Set.Set fof -> Set.Set fof -> Bool subsumes_clause cls1 cls2 =     failing (const False) (const True) (subsume Map.empty cls1)@@ -211,7 +213,7 @@ -- 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) =>+replace :: forall term f v fof atom. (FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) =>            Set.Set fof         -> Set.Set (Set.Set fof)         -> Set.Set (Set.Set fof)@@ -222,7 +224,7 @@                        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) =>+incorporate :: forall fof term f v atom. (FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) =>                Set.Set fof             -> Set.Set fof             -> Set.Set (Set.Set fof)@@ -232,7 +234,7 @@     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) =>+resloop2 :: forall fof term f v atom. (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) =>             Set.Set (Set.Set fof)          -> Set.Set (Set.Set fof)          -> Failing Bool@@ -246,26 +248,27 @@           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) =>+pure_resolution2 :: forall fof atom v term f. (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) =>                     fof -> Failing Bool pure_resolution2 fm = resloop2 Set.empty (simpcnf (specialize (pnf fm))) -resolution2 :: (Literal fof atom v, FirstOrderFormula fof atom v, Term term v f, Formula atom term v, Ord fof, Monad m) =>+resolution2 :: forall fof atom term v f m.+               (Literal fof atom, FirstOrderFormula fof atom v, PropositionalFormula fof atom, Term term v f, Atom atom term v, Ord fof, Monad m) =>                fof -> SkolemT v term m (Set.Set (Failing Bool))-resolution2 fm = askolemize ((.~.) (generalize fm)) >>= return . Set.map (pure_resolution2 . list_conj) . simpdnf+resolution2 fm = askolemize ((.~.) (generalize fm)) >>= return . Set.map (pure_resolution2 . list_conj) . (simpdnf :: fof -> Set.Set (Set.Set fof))  -- -------------------------------------------------------------------------  -- Positive (P1) resolution.                                                  -- -------------------------------------------------------------------------  -presolve_clauses :: (Literal fof atom v, FirstOrderFormula fof atom v, Term term v f, Formula atom term v, Ord fof) =>+presolve_clauses :: (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) =>                     Set.Set fof -> Set.Set fof -> Set.Set fof presolve_clauses cls1 cls2 =     if setAll positive cls1 || setAll positive cls2     then resolve_clauses cls1 cls2     else Set.empty -presloop :: (Literal fof atom v, FirstOrderFormula fof atom v, Term term v f, Formula atom term v, Ord fof) =>+presloop :: (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) =>             Set.Set (Set.Set fof) -> Set.Set (Set.Set fof) -> Failing Bool presloop used unused =     case Set.minView unused of@@ -279,28 +282,29 @@           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) =>+pure_presolution :: forall fof atom v term f. (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) =>                     fof -> Failing Bool pure_presolution fm = presloop Set.empty (simpcnf (specialize (pnf fm))) -presolution :: (Literal fof atom v, FirstOrderFormula fof atom v, Term term v f, Formula atom term v, Ord fof, Monad m) =>+presolution :: forall fof atom term v f m.+               (Literal fof atom, FirstOrderFormula fof atom v, PropositionalFormula fof atom, Term term v f, Atom atom term v, Ord fof, Monad m) =>                fof -> SkolemT v term m (Set.Set (Failing Bool)) presolution fm =-    askolemize ((.~.) (generalize fm)) >>= return . Set.map (pure_presolution . list_conj) . simpdnf+    askolemize ((.~.) (generalize fm)) >>= return . Set.map (pure_presolution . list_conj) . (simpdnf :: fof -> Set.Set (Set.Set fof))  -- -------------------------------------------------------------------------  -- Introduce a set-of-support restriction.                                    -- -------------------------------------------------------------------------  -pure_resolution3 :: (Literal fof atom v, FirstOrderFormula fof atom v, Term term v f, Formula atom term v, Ord fof) =>+pure_resolution3 :: (Literal fof atom, FirstOrderFormula fof atom v, Term term v f, Atom atom term v, Ord fof) =>                     fof -> Failing Bool pure_resolution3 fm =     uncurry resloop2 (Set.partition (setAny positive) (simpcnf (specialize (pnf fm)))) -resolution3 :: (Literal fof atom v, FirstOrderFormula fof atom v, Term term v f, Formula atom term v, Ord fof, Monad m) =>+resolution3 :: forall fof atom term v f m. (Literal fof atom, FirstOrderFormula fof atom v, PropositionalFormula fof atom, Term term v f, Atom atom term v, Ord fof, Monad m) =>                fof -> SkolemT v term m (Set.Set (Failing Bool)) resolution3 fm =-    askolemize ((.~.)(generalize fm)) >>= return . Set.map (pure_resolution3 . list_conj) . simpdnf+    askolemize ((.~.)(generalize fm)) >>= return . Set.map (pure_resolution3 . list_conj) . (simpdnf :: fof -> Set.Set (Set.Set fof)) {- -- -------------------------------------------------------------------------  -- The Pelletier examples again.
Data/Logic/Harrison/Skolem.hs view
@@ -2,31 +2,38 @@ {-# OPTIONS_GHC -Wall #-} module Data.Logic.Harrison.Skolem     ( simplify+    -- , simplify'     , lsimplify     , nnf+    -- , nnf'     , pnf+    -- , pnf'     , functions+    -- , functions'     , SkolemT+    , Skolem     , runSkolem     , runSkolemT     , specialize     , skolemize-    , literal+    -- , literal     , askolemize     , skolemNormalForm-    -- , substituteEq+    -- , prenex'+    , skolem     ) where  import Control.Monad.Identity (Identity(runIdentity))-import Control.Monad.State (StateT(runStateT), get, put)-import Data.Logic.Classes.Apply (Apply(foldApply))+import Control.Monad.State (StateT(runStateT))+import Data.Logic.Classes.Atom (Atom) import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..), binop)-import Data.Logic.Classes.Constants (Constants(fromBool, 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.Constants (Constants(fromBool, asBool), true, false)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(exists, for_all, foldFirstOrder), Quant(..), quant, toPropositional)+import Data.Logic.Classes.Formula (Formula(..))+import Data.Logic.Classes.Literal (Literal(foldLiteral)) import Data.Logic.Classes.Negate ((.~.))-import Data.Logic.Classes.Skolem (Skolem(toSkolem))+import Data.Logic.Classes.Propositional (PropositionalFormula(..))+import qualified Data.Logic.Classes.Skolem as C import Data.Logic.Classes.Term (Term(..)) import Data.Logic.Classes.Variable (Variable(variant)) import Data.Logic.Harrison.FOL (fv, subst)@@ -44,39 +51,46 @@ -- 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 :: (FirstOrderFormula fof atom v,+              -- Formula fof term v,+              Atom atom term v,+              Term term v f) => fof -> fof simplify1 fm =     foldFirstOrder qu co tf at fm     where       qu _ x p = if Set.member x (fv p) then fm else p       co ((:~:) p) = foldFirstOrder (\ _ _ _ -> fm) nco (fromBool . not) (\ _ -> fm) p-      co (BinOp l op r) =-          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+      co (BinOp l op r) = simplifyBinop l op r       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+simplifyBinop :: forall p. (Constants p, Combinable p) => p -> BinOp -> p -> p+simplifyBinop l op r =+    case (asBool l, op, asBool r) of+      (Just True,  (:&:), _         ) -> r+      (Just False, (:&:), _         ) -> false+      (_,          (:&:), Just True ) -> l+      (_,          (:&:), Just False) -> false+      (Just True,  (:|:), _         ) -> true+      (Just False, (:|:), _         ) -> r+      (_,          (:|:), Just True ) -> true+      (_,          (:|:), Just False) -> l+      (Just True,  (:=>:), _         ) -> r+      (Just False, (:=>:), _         ) -> true+      (_,          (:=>:), Just True ) -> true+      (_,          (:=>:), Just False) -> (.~.) l+      (Just False, (:<=>:), Just False) -> true+      (Just True,  (:<=>:), _         ) -> r+      (Just False, (:<=>:), _         ) -> (.~.) r+      (_,          (:<=>:), Just True ) -> l+      (_,          (:<=>:), Just False) -> (.~.) l+      _ -> binop l op r++simplify :: (FirstOrderFormula fof atom v,+             Atom atom term v,+             Term term v f) => fof -> fof simplify fm =     foldFirstOrder qu co tf at fm     where@@ -87,10 +101,10 @@       at _ = fm  -- | Just looks for double negatives and negated constants.-lsimplify :: Literal lit atom v => lit -> lit+lsimplify :: Literal lit atom => lit -> lit lsimplify fm = foldLiteral (lsimplify1 . (.~.) . lsimplify) fromBool (const fm) fm -lsimplify1 :: Literal lit atom v => lit -> lit+lsimplify1 :: Literal lit atom => lit -> lit lsimplify1 fm = foldLiteral (foldLiteral id (fromBool . not) (const fm)) fromBool (const fm) fm  @@ -120,7 +134,7 @@ -- Prenex normal form.                                                        -- -------------------------------------------------------------------------  -pullQuants :: forall formula atom v term f. (FirstOrderFormula formula atom v, Formula atom term v, Term term v f) =>+pullQuants :: forall formula atom v term f. (FirstOrderFormula formula atom v, {-Formula formula term v,-} Atom atom term v, Term term v f) =>               formula -> formula pullQuants fm =     foldFirstOrder (\ _ _ _ -> fm) pullQuantsCombine (\ _ -> fm) (\ _ -> fm) fm@@ -144,7 +158,7 @@ -- |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) =>+pullq :: (FirstOrderFormula formula atom v, Atom atom term v, Term term v f) =>          Bool -> Bool       -> formula       -> (v -> formula -> formula)@@ -161,7 +175,7 @@  -- |Recursivly apply pullQuants anywhere a quantifier might not be -- leftmost.-prenex :: (FirstOrderFormula formula atom v, Formula atom term v, Term term v f) =>+prenex :: (FirstOrderFormula formula atom v, {-Formula formula term v,-} Atom atom term v, Term term v f) =>           formula -> formula  prenex fm =     foldFirstOrder qu co (\ _ -> fm) (\ _ -> fm) fm@@ -172,22 +186,17 @@       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 :: (FirstOrderFormula formula atom v, Atom atom term v, Term term v f) => formula -> formula pnf = prenex . nnf . simplify  -- -------------------------------------------------------------------------  -- Get the functions in a term and formula.                                   -- -------------------------------------------------------------------------  -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+-- FIXME: the function parameter should be a method in the Atom class,+-- but we need to add a type parameter f to it first.+functions :: forall formula atom f. (Formula formula atom, Ord f) => (atom -> Set.Set (f, Int)) -> formula -> Set.Set (f, Int)+functions fa fm = foldAtoms (\ s a -> Set.union s (fa a)) Set.empty fm  -- -------------------------------------------------------------------------  -- State monad for generating Skolem functions and constants.@@ -205,8 +214,6 @@     = 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@@ -214,16 +221,25 @@         -- function.       } +-- | The state associated with the Skolem monad. newSkolemState :: SkolemState v term-newSkolemState = SkolemState { skolemCount = 1-                             -- , skolemMap = Map.empty-                             , univQuant = [] }+newSkolemState+    = SkolemState+      { skolemCount = 1+      , univQuant = []+      } +-- | The Skolem monad transformer type SkolemT v term m = StateT (SkolemState v term) m +-- | Run a computation in the Skolem monad. runSkolem :: SkolemT v term Identity a -> a runSkolem = runIdentity . runSkolemT +-- | The Skolem monad+type Skolem v term = StateT (SkolemState v term) Identity++-- | Run a computation in a stacked invocation of the Skolem monad. runSkolemT :: Monad m => SkolemT v term m a -> m a runSkolemT action = (runStateT action) newSkolemState >>= return . fst @@ -238,25 +254,37 @@ -- 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 :: (Monad m,+           FirstOrderFormula fof atom v,+           -- PropositionalFormula pf atom,+           -- Formula formula term v,+           Atom atom term v,+           Term term v f) =>+          fof -> SkolemT v term m fof skolem fm =-    foldFirstOrder qu co (\ _ -> return fm) (\ _ -> return fm) fm+    foldFirstOrder qu co (return . fromBool) (return . atomic) fm     where+      -- We encountered an existentially quantified variable y,+      -- allocate a new skolem function fx and do a substitution to+      -- replace occurrences of y with fx.  The value of the Skolem+      -- function is assumed to equal the value of y which satisfies+      -- the formula.       qu Exists y p =           do let xs = fv fm-             state <- get-             let f = toSkolem (skolemCount state)-             put (state {skolemCount = skolemCount state + 1})-             let fx = fApp f (map vt (Set.toList xs))+             let fx = fApp (C.toSkolem y) (map vt (Set.toAscList xs))              skolem (subst (Map.singleton y fx) p)       qu Forall x p = skolem p >>= return . for_all x       co (BinOp l (:&:) r) = skolem2 (.&.) l r       co (BinOp l (:|:) r) = skolem2 (.|.) l r       co _ = return fm -skolem2 :: (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f) =>-           (formula -> formula -> formula) -> formula -> formula -> SkolemT v term m formula+skolem2 :: (Monad m,+            FirstOrderFormula fof atom v,+            -- PropositionalFormula pf atom,+            -- Formula formula term v,+            Atom atom term v,+            Term term v f) =>+           (fof -> fof -> fof) -> fof -> fof -> SkolemT v term m fof skolem2 cons p q =     skolem p >>= \ p' ->     skolem q >>= \ q' ->@@ -268,10 +296,18 @@  -- |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 :: forall m fof atom term v f.+              (Monad m,+               FirstOrderFormula fof atom v,+               Atom atom term v,+               Term term v f) =>+              fof -> SkolemT v term m fof askolemize = skolem . nnf . simplify +-- | Remove the leading universal quantifiers.  After a call to pnf+-- this will be all the universal quantifiers, and the skolemization+-- will have already turned all the existential quantifiers into+-- skolem functions. specialize :: forall fof atom v. FirstOrderFormula fof atom v => fof -> fof specialize f =     foldFirstOrder q (\ _ -> f) (\ _ -> f) (\ _ -> f) f@@ -279,14 +315,22 @@       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+-- | Skolemize and then specialize.  Because we know all quantifiers+-- are gone we can convert to any instance of PropositionalFormula.+skolemize :: forall m fof atom term v f pf atom2. (Monad m,+              FirstOrderFormula fof atom v,+              PropositionalFormula pf atom2,+              Atom atom term v,+              Term term v f,+              Eq pf) =>+             (atom -> atom2) -> fof -> SkolemT v term m pf+skolemize ca fm = askolemize fm >>= return . (toPropositional ca :: fof -> pf) . specialize . pnf +{- -- | Convert a first order formula into a disjunct of conjuncts of -- literals.  Note that this can convert any instance of -- FirstOrderFormula into any instance of Literal.-literal :: forall fof atom term v p f lit. (Literal fof atom v, Apply atom p term, Term term v f, Literal lit atom v, Ord lit) =>+literal :: forall fof atom term v p f lit. (Literal fof atom, Apply atom p term, Term term v f, Literal lit atom, Formula lit atom, Ord lit) =>            fof -> Set.Set (Set.Set lit) literal fm =     foldLiteral neg tf at fm@@ -295,13 +339,17 @@       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+      at x = foldApply (\ _ _ -> Set.singleton (Set.singleton (atomic x))) tf x+-}  -- |We get Skolem Normal Form by skolemizing and then converting to -- Prenex Normal Form, and finally eliminating the remaining quantifiers. skolemNormalForm :: (FirstOrderFormula fof atom v,-                     Formula atom term v,+                     PropositionalFormula pf atom2,+                     -- Formula fof term v,+                     -- Formula pf term v,+                     Atom atom term v,                      Term term v f,-                     Monad m, Eq fof) =>-                    fof -> SkolemT v term m fof-skolemNormalForm f = askolemize f >>= return . specialize . pnf+                     Monad m, Ord fof, Eq pf) =>+                    (atom -> atom2) -> fof -> SkolemT v term m pf+skolemNormalForm = skolemize
Data/Logic/Harrison/Tableaux.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings, RankNTypes, ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Data.Logic.Harrison.Tableaux     ( unify_literals@@ -7,12 +7,26 @@     ) where  import Control.Applicative.Error (Failing(..))+--import Data.List (partition)+import qualified Data.Logic.Classes.Atom as C+--import Data.Logic.Classes.Combine ((.&.), (.=>.))+--import Data.Logic.Classes.Constants (false) import Data.Logic.Classes.Equals (AtomEq, zipAtomsEq)-import qualified Data.Logic.Classes.Formula as C+import Data.Logic.Classes.FirstOrder (FirstOrderFormula, exists, for_all)+import Data.Logic.Classes.Formula (Formula(..))+import Data.Logic.Classes.Negate (positive, (.~.)) import Data.Logic.Classes.Literal (Literal, zipLiterals)-import Data.Logic.Classes.Term (Term(..))+import Data.Logic.Classes.Propositional (PropositionalFormula)+import Data.Logic.Classes.Term (Term(..), vt)+import Data.Logic.Harrison.FOL (subst, generalize)+import Data.Logic.Harrison.Herbrand (davisputnam)+import Data.Logic.Harrison.Lib (allpairs, settryfind, distrib')+import Data.Logic.Harrison.Prop (simpdnf)+import Data.Logic.Harrison.Skolem (runSkolem, skolemize) import Data.Logic.Harrison.Unif (unify) import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.String (IsString(..)) import Debug.Trace (trace)  -- =========================================================================@@ -25,7 +39,10 @@ -- 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) =>+unify_literals :: forall lit atom term v f.+                  (Literal lit atom,+                   C.Atom atom term v,+                   Term term v f) =>                   Map.Map v term -> lit -> lit -> Failing (Map.Map v term) unify_literals env f1 f2 =     maybe err id (zipLiterals co tf at f1 f2)@@ -33,7 +50,7 @@       -- 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 :: atom -> atom -> Maybe (Failing (Map.Map v term))       at a1 a2 = Just $ C.unify env a1 a2       err = Failure ["Can't unify literals"] @@ -54,69 +71,105 @@ -- -------------------------------------------------------------------------  -- Unify complementary literals.                                              -- ------------------------------------------------------------------------- -{--unify_complements env (p,q) = unify_literals env (p,negate q) +unify_complements :: forall lit atom term v f.+                     (Literal lit atom,+                      C.Atom atom term v,+                      Term term v f) =>+                     Map.Map v term -> lit -> lit -> Failing (Map.Map v term)+unify_complements env p q = unify_literals env p ((.~.) q)+ -- -------------------------------------------------------------------------  -- Unify and refute a set of disjuncts.                                       -- -------------------------------------------------------------------------  +unify_refute :: (Literal lit atom, Term term v f, C.Atom atom term v, Ord lit) => Set.Set (Set.Set lit) -> Map.Map v term -> Failing (Map.Map v term) unify_refute djs env =-  case 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);;+    case Set.minView djs of+      Nothing -> Success env+      Just (d, odjs) ->+          settryfind (\ (p, n) -> unify_complements env p n >>= unify_refute odjs) pairs+          where+            pairs = allpairs (,) pos neg+            (pos,neg) = Set.partition positive d  -- -------------------------------------------------------------------------  -- Hence a Prawitz-like procedure (using unification on DNF).                 -- -------------------------------------------------------------------------  +prawitz_loop :: forall atom v term f lit. (Literal lit atom, Term term v f, C.Atom atom term v, Ord lit) =>+                Set.Set (Set.Set lit) -> [v] -> Set.Set (Set.Set lit) -> Int -> (Map.Map v term, Int) prawitz_loop djs0 fvs djs n =     let l = length fvs in-    let newvars = map (\ k -> "_" ++ 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+    let newvars = map (\ k -> fromString ("_" ++ show (n * l + k))) [1..l] in+    let inst = Map.fromList (zip fvs (map vt newvars)) in+    let djs1 = distrib' (Set.map (Set.map (mapAtoms (atomic . substitute' inst))) djs0) djs in+    case unify_refute djs1 Map.empty of+      Failure _ -> prawitz_loop djs0 fvs djs1 (n + 1)+      Success env -> (env, n + 1)+    where+      substitute' :: Map.Map v term -> atom -> atom+      substitute' = C.substitute +-- prawitz :: forall fof atom v. (FirstOrderFormula fof atom v, Ord fof) => fof -> Int+prawitz :: forall fof atom term v f lit pf.+           (FirstOrderFormula fof atom v,+            PropositionalFormula pf atom,+            Literal lit atom,+            Term term v f,+            C.Atom atom term v) =>+           fof -> Int prawitz fm =-  let fm0 = skolemize(Not(generalize fm)) in-  snd(prawitz_loop (simpdnf fm0) (fv fm0) [[]] 0);;+    snd (prawitz_loop dnf (Set.toList fvs) dnf0 0 :: (Map.Map v term, Int))+    where+      dnf0 = (Set.singleton Set.empty) :: Set.Set (Set.Set lit)+      dnf = simpdnf pf :: Set.Set (Set.Set lit)+      fvs = foldAtoms (\ s (a :: atom) -> Set.union (C.freeVariables a) s) Set.empty pf :: Set.Set v+      pf = runSkolem (skolemize id ((.~.)(generalize fm))) :: pf  -- -------------------------------------------------------------------------  -- 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+          fm = (for_all "x" (for_all "y" (exists "z" (for_all "w" (pApp "P" [vt "x"] .&. pApp "Q" [vt "y"] .=>.+                                                                   pApp "R" [vt "z"] .&. pApp "U" [vt "w"]))))) .=>.+               (exists "x" (exists "y" (pApp "P" [vt "x"] .&. pApp "Q" [vt "y"]))) .=>. (exists "z" (pApp "R" [vt "z"]))+          expected = 1+-}  -- -------------------------------------------------------------------------  -- Comparison of number of ground instances.                                  -- -------------------------------------------------------------------------  -compare fm =-    (prawitz fm, davisputnam fm) {-+compare :: forall fof pf lit atom term v f.+           (FirstOrderFormula fof atom v,+            PropositionalFormula pf atom,+            Literal pf atom,+            Term term v f,+            C.Atom atom term v,+            IsString f) =>+           (atom -> Set.Set (f, Int)) -> fof -> (Int, Failing Int)+-}+-- compare fa fm = (prawitz fm, davisputnam fa fm)+{- START_INTERACTIVE;; test02 = TestCase $ assertEqual "p19" expected input-    where input = compare (exists "x" (forall "y" (for_all "z" ((pApp "P" [var "y"] .=>. pApp "Q" [var "z"]) .=>. pApp "P" [var "x"] .=>. pApp "Q" [var "x"]))))+    where input = compare (exists "x" (forall "y" (for_all "z" ((pApp "P" [vt "y"] .=>. pApp "Q" [vt "z"]) .=>. pApp "P" [vt "x"] .=>. pApp "Q" [vt "x"]))))  let p20 = compare- <<(forall x y. exists z. forall w. P[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"])>>;;+ <<(forall x y. exists z. forall w. P[vt "x"] .&. Q[vt "y"] .=>. R[vt "z"] .&. U[vt "w"])+   .=>. (exists x y. P[vt "x"] .&. Q[vt "y"]) .=>. (exists z. R[vt "z"])>>;;  let p24 = compare- <<~(exists x. U[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"])>>;;+ <<~(exists x. U[vt "x"] .&. Q[vt "x"]) .&.+   (forall x. P[vt "x"] .=>. Q[vt "x"] .|. R[vt "x"]) .&.+   ~(exists x. P[vt "x"] .=>. (exists x. Q[vt "x"])) .&.+   (forall x. Q[vt "x"] .&. R[vt "x"] .=>. U[vt "x"])+   .=>. (exists x. P[vt "x"] .&. R[vt "x"])>>;;  let p39 = compare  <<~(exists x. forall y. P(y,x) .<=>. ~P(y,y))>>;;@@ -133,17 +186,17 @@  ***** -}  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"])>>;;+ <<(forall x. P[vt "x"] .=>. (exists y. G[vt "y"] .&. H(x,y)) .&.+   (exists y. G[vt "y"] .&. ~H(x,y))) .&.+   (exists x. J[vt "x"] .&. (forall y. G[vt "y"] .=>. H(x,y)))+   .=>. (exists x. J[vt "x"] .&. ~P[vt "x"])>>;;  let p59 = compare- <<(forall x. P[var "x"] .<=>. ~P(f[var "x"])) .=>. (exists x. P[var "x"] .&. ~P(f[var "x"]))>>;;+ <<(forall x. P[vt "x"] .<=>. ~P(f[vt "x"])) .=>. (exists x. P[vt "x"] .&. ~P(f[vt "x"]))>>;;  let p60 = compare- <<forall x. P(x,f[var "x"]) .<=>.-             exists y. (forall z. P(z,y) .=>. P(z,f[var "x"])) .&. P(x,y)>>;;+ <<forall x. P(x,f[vt "x"]) .<=>.+             exists y. (forall z. P(z,y) .=>. P(z,f[vt "x"])) .&. P(x,y)>>;;  END_INTERACTIVE;; @@ -160,14 +213,13 @@   | 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 y = Vt("_" ++ string_of_int k) in       let p' = subst (x |=> y) p in       tableau (p' : unexp@[Forall(x,p)],lits,n-1) cont (env,k+1)   | fm : unexp ->       try tryfind (\ l -> cont(unify_complements env (fm,l),k)) lits       with Failure _ -> tableau (unexp,fm : lits,n) cont (env,k);; -}--}  -- | Try f with higher and higher values of n until it succeeds, or -- optional maximum depth limit is exceeded.@@ -184,7 +236,7 @@  {- let tabrefute fms =-  deepen (\ n -> tableau (fms,[],n) (\ x -> x) (undefined,0); n) 0;;+  deepen (\ n -> tableau (fms,[],n) (\ x -> x) (Map.empty,0); n) 0;;  let tab fm =   let sfm = askolemize(Not(generalize fm)) in@@ -197,12 +249,12 @@ 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))) .<=>.+     P[vt "a"] .&. (P[vt "x"] .=>. (exists y. P[vt "y"] .&. R(x,y))) .=>.+     (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))) .<=>.    (forall x.-     (~P[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))))>>;;+     (~P[vt "a"] .|. P[vt "x"] .|. (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))) .&.+     (~P[vt "a"] .|. ~(exists y. P[vt "y"] .&. R(x,y)) .|.+     (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))))>>;; END_INTERACTIVE;;  -- ------------------------------------------------------------------------- @@ -218,10 +270,10 @@  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"])))>>;;+ <<((exists x. forall y. P[vt "x"] .<=>. P[vt "y"]) .<=>.+    ((exists x. Q[vt "x"]) .<=>. (forall y. Q[vt "y"]))) .<=>.+   ((exists x. forall y. Q[vt "x"] .<=>. Q[vt "y"]) .<=>.+    ((exists x. P[vt "x"]) .<=>. (forall y. P[vt "y"])))>>;;  -- -------------------------------------------------------------------------  -- Another nice example from EWD 1602.                                       @@ -230,9 +282,9 @@ 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"])>>;;+   (forall x y. f[vt "x"] <= y .<=>. x <= g[vt "y"])+   .=>. (forall x y. x <= y .=>. f[vt "x"] <= f[vt "y"]) .&.+       (forall x y. x <= y .=>. g[vt "x"] <= g[vt "y"])>>;; END_INTERACTIVE;;  -- ------------------------------------------------------------------------- @@ -297,89 +349,89 @@ -- -------------------------------------------------------------------------   let p18 = time splittab- <<exists y. forall x. P[var "y"] .=>. P[var "x"]>>;;+ <<exists y. forall x. P[vt "y"] .=>. P[vt "x"]>>;;  let p19 = time splittab- <<exists x. forall y z. (P[var "y"] .=>. Q[var "z"]) .=>. P[var "x"] .=>. Q[var "x"]>>;;+ <<exists x. forall y z. (P[vt "y"] .=>. Q[vt "z"]) .=>. P[vt "x"] .=>. Q[vt "x"]>>;;  let p20 = time splittab- <<(forall x y. exists z. forall w. P[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"])>>;;+ <<(forall x y. exists z. forall w. P[vt "x"] .&. Q[vt "y"] .=>. R[vt "z"] .&. U[vt "w"])+   .=>. (exists x y. P[vt "x"] .&. Q[vt "y"]) .=>. (exists z. R[vt "z"])>>;;  let p21 = time splittab- <<(exists x. P .=>. Q[var "x"]) .&. (exists x. Q[var "x"] .=>. P)-   .=>. (exists x. P .<=>. Q[var "x"])>>;;+ <<(exists x. P .=>. Q[vt "x"]) .&. (exists x. Q[vt "x"] .=>. P)+   .=>. (exists x. P .<=>. Q[vt "x"])>>;;  let p22 = time splittab- <<(forall x. P .<=>. Q[var "x"]) .=>. (P .<=>. (forall x. Q[var "x"]))>>;;+ <<(forall x. P .<=>. Q[vt "x"]) .=>. (P .<=>. (forall x. Q[vt "x"]))>>;;  let p23 = time splittab- <<(forall x. P .|. Q[var "x"]) .<=>. P .|. (forall x. Q[var "x"])>>;;+ <<(forall x. P .|. Q[vt "x"]) .<=>. P .|. (forall x. Q[vt "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"])>>;;+ <<~(exists x. U[vt "x"] .&. Q[vt "x"]) .&.+   (forall x. P[vt "x"] .=>. Q[vt "x"] .|. R[vt "x"]) .&.+   ~(exists x. P[vt "x"] .=>. (exists x. Q[vt "x"])) .&.+   (forall x. Q[vt "x"] .&. R[vt "x"] .=>. U[vt "x"]) .=>.+   (exists x. P[vt "x"] .&. R[vt "x"])>>;;  let p25 = time splittab- <<(exists x. P[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"])>>;;+ <<(exists x. P[vt "x"]) .&.+   (forall x. U[vt "x"] .=>. ~G[vt "x"] .&. R[vt "x"]) .&.+   (forall x. P[vt "x"] .=>. G[vt "x"] .&. U[vt "x"]) .&.+   ((forall x. P[vt "x"] .=>. Q[vt "x"]) .|. (exists x. Q[vt "x"] .&. P[vt "x"]))+   .=>. (exists x. Q[vt "x"] .&. P[vt "x"])>>;;  let p26 = time splittab- <<((exists x. P[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"]))>>;;+ <<((exists x. P[vt "x"]) .<=>. (exists x. Q[vt "x"])) .&.+   (forall x y. P[vt "x"] .&. Q[vt "y"] .=>. (R[vt "x"] .<=>. U[vt "y"]))+   .=>. ((forall x. P[vt "x"] .=>. R[vt "x"]) .<=>. (forall x. Q[vt "x"] .=>. U[vt "x"]))>>;;  let p27 = time splittab- <<(exists x. P[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"])>>;;+ <<(exists x. P[vt "x"] .&. ~Q[vt "x"]) .&.+   (forall x. P[vt "x"] .=>. R[vt "x"]) .&.+   (forall x. U[vt "x"] .&. V[vt "x"] .=>. P[vt "x"]) .&.+   (exists x. R[vt "x"] .&. ~Q[vt "x"])+   .=>. (forall x. U[vt "x"] .=>. ~R[vt "x"])+       .=>. (forall x. U[vt "x"] .=>. ~V[vt "x"])>>;;  let p28 = time splittab- <<(forall x. P[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"])>>;;+ <<(forall x. P[vt "x"] .=>. (forall x. Q[vt "x"])) .&.+   ((forall x. Q[vt "x"] .|. R[vt "x"]) .=>. (exists x. Q[vt "x"] .&. R[vt "x"])) .&.+   ((exists x. R[vt "x"]) .=>. (forall x. L[vt "x"] .=>. M[vt "x"])) .=>.+   (forall x. P[vt "x"] .&. L[vt "x"] .=>. M[vt "x"])>>;;  let p29 = time splittab- <<(exists x. P[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"]))>>;;+ <<(exists x. P[vt "x"]) .&. (exists x. G[vt "x"]) .=>.+   ((forall x. P[vt "x"] .=>. H[vt "x"]) .&. (forall x. G[vt "x"] .=>. J[vt "x"]) .<=>.+    (forall x y. P[vt "x"] .&. G[vt "y"] .=>. H[vt "x"] .&. J[vt "y"]))>>;;  let p30 = time splittab- <<(forall x. P[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"])>>;;+ <<(forall x. P[vt "x"] .|. G[vt "x"] .=>. ~H[vt "x"]) .&.+   (forall x. (G[vt "x"] .=>. ~U[vt "x"]) .=>. P[vt "x"] .&. H[vt "x"])+   .=>. (forall x. U[vt "x"])>>;;  let p31 = time splittab- <<~(exists x. P[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"])>>;;+ <<~(exists x. P[vt "x"] .&. (G[vt "x"] .|. H[vt "x"])) .&.+   (exists x. Q[vt "x"] .&. P[vt "x"]) .&.+   (forall x. ~H[vt "x"] .=>. J[vt "x"])+   .=>. (exists x. Q[vt "x"] .&. J[vt "x"])>>;;  let p32 = time splittab- <<(forall x. P[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"])>>;;+ <<(forall x. P[vt "x"] .&. (G[vt "x"] .|. H[vt "x"]) .=>. Q[vt "x"]) .&.+   (forall x. Q[vt "x"] .&. H[vt "x"] .=>. J[vt "x"]) .&.+   (forall x. R[vt "x"] .=>. H[vt "x"])+   .=>. (forall x. P[vt "x"] .&. R[vt "x"] .=>. J[vt "x"])>>;;  let p33 = time splittab- <<(forall x. P[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"])>>;;+ <<(forall x. P[vt "a"] .&. (P[vt "x"] .=>. P[vt "b"]) .=>. P[vt "c"]) .<=>.+   (forall x. P[vt "a"] .=>. P[vt "x"] .|. P[vt "c"]) .&. (P[vt "a"] .=>. P[vt "b"] .=>. P[vt "c"])>>;;  let p34 = time splittab- <<((exists x. forall y. P[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"])))>>;;+ <<((exists x. forall y. P[vt "x"] .<=>. P[vt "y"]) .<=>.+    ((exists x. Q[vt "x"]) .<=>. (forall y. Q[vt "y"]))) .<=>.+   ((exists x. forall y. Q[vt "x"] .<=>. Q[vt "y"]) .<=>.+    ((exists x. P[vt "x"]) .<=>. (forall y. P[vt "y"])))>>;;  let p35 = time splittab  <<exists x y. P(x,y) .=>. (forall x y. P(x,y))>>;;@@ -405,12 +457,12 @@  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))) .<=>.+     P[vt "a"] .&. (P[vt "x"] .=>. (exists y. P[vt "y"] .&. R(x,y))) .=>.+     (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))) .<=>.    (forall x.-     (~P[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))))>>;;+     (~P[vt "a"] .|. P[vt "x"] .|. (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))) .&.+     (~P[vt "a"] .|. ~(exists y. P[vt "y"] .&. R(x,y)) .|.+     (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))))>>;;  let p39 = time splittab  <<~(exists x. forall y. P(y,x) .<=>. ~P(y,y))>>;;@@ -431,27 +483,27 @@    .=>. 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"])>>;;+ <<(forall x. P[vt "x"] .=>. (exists y. G[vt "y"] .&. H(x,y)) .&.+   (exists y. G[vt "y"] .&. ~H(x,y))) .&.+   (exists x. J[vt "x"] .&. (forall y. G[vt "y"] .=>. H(x,y))) .=>.+   (exists x. J[vt "x"] .&. ~P[vt "x"])>>;;  let p45 = time splittab  <<(forall x.-     P[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)))>>;;+     P[vt "x"] .&. (forall y. G[vt "y"] .&. H(x,y) .=>. J(x,y)) .=>.+       (forall y. G[vt "y"] .&. H(x,y) .=>. R[vt "y"])) .&.+   ~(exists y. L[vt "y"] .&. R[vt "y"]) .&.+   (exists x. P[vt "x"] .&. (forall y. H(x,y) .=>.+     L[vt "y"]) .&. (forall y. G[vt "y"] .&. H(x,y) .=>. J(x,y))) .=>.+   (exists x. P[vt "x"] .&. ~(exists y. G[vt "y"] .&. H(x,y)))>>;;  let p46 = time splittab- <<(forall x. P[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"])>>;;+ <<(forall x. P[vt "x"] .&. (forall y. P[vt "y"] .&. H(y,x) .=>. G[vt "y"]) .=>. G[vt "x"]) .&.+   ((exists x. P[vt "x"] .&. ~G[vt "x"]) .=>.+    (exists x. P[vt "x"] .&. ~G[vt "x"] .&.+               (forall y. P[vt "y"] .&. ~G[vt "y"] .=>. J(x,y)))) .&.+   (forall x y. P[vt "x"] .&. P[vt "y"] .&. H(x,y) .=>. ~J(y,x)) .=>.+   (forall x. P[vt "x"] .=>. G[vt "x"])>>;;  -- -------------------------------------------------------------------------  -- Well-known "Agatha" example; cf. Manthey and Bry, CADE-9.                 @@ -464,7 +516,7 @@    (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. lives[vt "x"] .&. ~richer(x,agatha) .=>. hates(butler,x)) .&.    (forall x. hates(agatha,x) .=>. hates(butler,x)) .&.    (forall x. ~hates(x,agatha) .|. ~hates(x,butler) .|. ~hates(x,charles))    .=>. killed(agatha,agatha) .&.@@ -472,9 +524,9 @@        ~killed(charles,agatha)>>;;  let p57 = time splittab- <<P(f([var "a"],b),f(b,c)) .&.+ <<P(f([vt "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))+   (forall [vt "x"] y z. P(x,y) .&. P(y,z) .=>. P(x,z))    .=>. P(f(a,b),f(a,c))>>;;  -- ------------------------------------------------------------------------- @@ -483,14 +535,14 @@  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"])))>>;;+    ((P[vt "x"] .&. Q[vt "y"]) .=>. ((P[vt "v"] .|. R[vt "w"])  .&. (R[vt "z"] .=>. Q[vt "v"])))>>;;  let p59 = time splittab- <<(forall x. P[var "x"] .<=>. ~P(f[var "x"])) .=>. (exists x. P[var "x"] .&. ~P(f[var "x"]))>>;;+ <<(forall x. P[vt "x"] .<=>. ~P(f[vt "x"])) .=>. (exists x. P[vt "x"] .&. ~P(f[vt "x"]))>>;;  let p60 = time splittab- <<forall x. P(x,f[var "x"]) .<=>.-            exists y. (forall z. P(z,y) .=>. P(z,f[var "x"])) .&. P(x,y)>>;;+ <<forall x. P(x,f[vt "x"]) .<=>.+            exists y. (forall z. P(z,y) .=>. P(z,f[vt "x"])) .&. P(x,y)>>;;  -- -------------------------------------------------------------------------  -- From Gilmore's classic paper.                                             @@ -500,10 +552,10 @@  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"]>>;;+      ((F[vt "y"] .=>. G[vt "y"]) .<=>. F[vt "x"]) .&.+      ((F[vt "y"] .=>. H[vt "y"]) .<=>. G[vt "x"]) .&.+      (((F[vt "y"] .=>. G[vt "y"]) .=>. H[vt "y"]) .<=>. H[vt "x"])+      .=>. F[vt "z"] .&. G[vt "z"] .&. H[vt "z"]>>;;   ***** -} @@ -518,8 +570,8 @@  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(y,z) .=>. (G[vt "y"] .=>. H[vt "x"])) .=>. F(x,x)) .&.+        ((F(z,x) .=>. G[vt "x"]) .=>. H[vt "z"]) .&.         F(x,y)         .=>. F(z,z)>>;; @@ -540,14 +592,14 @@             (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)>>;;+ <<(forall x. K[vt "x"] .=>. exists y. L[vt "y"] .&. (F(x,y) .=>. G(x,y))) .&.+   (exists z. K[vt "z"] .&. forall u. L[vt "u"] .=>. F(z,u))+   .=>. exists v w. K[vt "v"] .&. L[vt "w"] .&. G(v,w)>>;;  let gilmore_8 = time splittab  <<exists x. forall y z.-        ((F(y,z) .=>. (G[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(y,z) .=>. (G[vt "y"] .=>. (forall u. exists v. H(u,v,x)))) .=>. F(x,x)) .&.+        ((F(z,x) .=>. G[vt "x"]) .=>. (forall u. exists v. H(u,v,z))) .&.         F(x,y)         .=>. F(z,z)>>;; @@ -571,4 +623,5 @@         ((F(x,y) .&. G(x,y)) .=>. (G(x,z) .&. G(z,z)))>>;;  ************ -}+ -}
Data/Logic/Instances/Chiou.hs view
@@ -14,19 +14,20 @@     ) where  import Data.Generics (Data, Typeable)-import Data.Logic.Classes.Apply (Apply(..))-import Data.Logic.Classes.Arity (Arity)+import Data.Logic.Classes.Apply (Apply(..), Predicate)+import Data.Logic.Classes.Atom (Atom) import Data.Logic.Classes.Combine (Combinable(..), BinOp(..), Combination(..))-import Data.Logic.Classes.Constants (Constants(..), asBool)+import Data.Logic.Classes.Constants (Constants(..), asBool, true, false) 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.FirstOrder (FirstOrderFormula(..), Quant(..), quant', pApp, prettyFirstOrder, fixityFirstOrder, foldAtomsFirstOrder, mapAtomsFirstOrder)+import Data.Logic.Classes.Formula (Formula(..)) import Data.Logic.Classes.Negate (Negatable(..), (.~.))-import Data.Logic.Classes.Term (Term(..))+import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..))+import Data.Logic.Classes.Term (Term(..), Function)+import Data.Logic.Classes.Variable (Variable) import qualified Data.Logic.Classes.FirstOrder as L import Data.Logic.Classes.Propositional (PropositionalFormula(..)) import Data.Logic.Classes.Skolem (Skolem(..))-import Data.Logic.Classes.Variable (Variable) import Data.String (IsString(..))  data Sentence v p f@@ -59,8 +60,12 @@     foldNegation normal inverted (Not x) = foldNegation inverted normal x     foldNegation normal _ x = normal x -instance Constants p => Constants (Sentence v p f) where+instance (Constants p, Eq (Sentence v p f)) => Constants (Sentence v p f) where     fromBool x = Predicate (fromBool x) []+    asBool x+        | fromBool True == x = Just True+        | fromBool False == x = Just False+        | True = Nothing  instance ({- Constants (Sentence v p f), -} Ord v, Ord p, Ord f) => Combinable (Sentence v p f) where     x .<=>. y = Connective x Equiv y@@ -68,16 +73,17 @@     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, 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+instance (Predicate p, Function f v) => Formula (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 x@(Predicate _ _) = x     atomic x@(Equal _ _) = x+    foldAtoms = foldAtomsFirstOrder+    mapAtoms = mapAtomsFirstOrder++instance (Formula (Sentence v p f) (Sentence v p f), Variable v, Predicate p, Function f v, Combinable (Sentence v p f)) =>+         PropositionalFormula (Sentence v p f) (Sentence v p f) where     foldPropositional co tf at formula =         case formula of           Not x -> co ((:~:) x)@@ -89,38 +95,42 @@           Predicate p ts -> maybe (at (Predicate p ts)) tf (asBool p)           Equal t1 t2 -> at (Equal t1 t2) -data AtomicFunction+data AtomicFunction v     = AtomicFunction String     -- This is redundant with the SkolemFunction and SkolemConstant     -- constructors in the Chiou Term type.-    | AtomicSkolemFunction Int+    | AtomicSkolemFunction v     deriving (Eq, Show) -instance IsString AtomicFunction where+instance IsString (AtomicFunction v) where     fromString = AtomicFunction -instance Skolem AtomicFunction where-    toSkolem = AtomicSkolemFunction -    fromSkolem (AtomicSkolemFunction n) = Just n-    fromSkolem _ = Nothing+instance Variable v => Skolem (AtomicFunction v) v where+    toSkolem = AtomicSkolemFunction+    isSkolem (AtomicSkolemFunction _) = True+    isSkolem _ = False  -- 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+instance (Variable v, Predicate p, Function f v) => Apply (Sentence v p f) p (CTerm v f) where     foldApply ap tf (Predicate p ts) = maybe (ap p ts) tf (asBool p)     foldApply _ _ _ = error "Data.Logic.Instances.Chiou: Invalid atom"     apply' = Predicate -instance (Arity p, Show p, Constants p, Eq p) => AtomEq (Sentence v p f) p (CTerm v f) where+instance Predicate p => AtomEq (Sentence v p f) p (CTerm v f) where     foldAtomEq ap tf _ (Predicate p ts) = if p == true then tf True else if p == false then tf False else ap p ts     foldAtomEq _ _ eq (Equal t1 t2) = eq t1 t2     foldAtomEq _ _ _ _ = error "Data.Logic.Instances.Chiou: Invalid atom"     equals = Equal     applyEq' = Predicate -instance (Ord v, IsString v, Variable v, Data v, Show v,-          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)) =>+instance (FirstOrderFormula (Sentence v p f) (Sentence v p f) v, Variable v, Predicate p, Function f v) => Pretty (Sentence v p f) where+    pretty = prettyFirstOrder (\ _ a -> pretty a) pretty 0++instance (Formula (Sentence v p f) (Sentence v p f), Predicate p, Function f v, Variable v) => HasFixity (Sentence v p f) where+    fixity = fixityFirstOrder++instance (Formula (Sentence v p f) (Sentence v p f),+          Variable v, Predicate p, Function f v) =>           FirstOrderFormula (Sentence v p f) (Sentence v p f) v where     for_all v x = Quantifier ForAll [v] x     exists v x = Quantifier ExistsCh [v] x@@ -166,11 +176,8 @@           (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) => Term (CTerm v f) v f where+instance (Variable v, Function f v) => Term (CTerm v f) v f where     foldTerm v fn t =         case t of           Variable x -> v x@@ -200,8 +207,12 @@     | NormalVariable v     deriving (Eq, Ord, Data, Typeable) -instance Constants p => Constants (NormalSentence v p f) where+instance (Constants p, Eq (NormalSentence v p f)) => Constants (NormalSentence v p f) where     fromBool x = NFPredicate (fromBool x) []+    asBool x+        | fromBool True == x = Just True+        | fromBool False == x = Just False+        | True = Nothing  instance Negatable (NormalSentence v p f) where     negatePrivate = NFNot@@ -222,10 +233,19 @@     x .!=. y = NFNot (NFEqual x y) -} -instance (Combinable (NormalSentence v p f), Term (NormalTerm v f) v f,-          IsString v, Show v,-          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+instance (Formula (NormalSentence v p f) (NormalSentence v p f),+          Variable v, Predicate p, Function f v, Combinable (NormalSentence v p f)) => Pretty (NormalSentence v p f) where+    pretty = prettyFirstOrder (\ _ a -> pretty a) pretty 0++instance (Predicate p, Function f v, Combinable (NormalSentence v p f)) => Formula (NormalSentence v p f) (NormalSentence v p f) where+    atomic x@(NFPredicate _ _) = x+    atomic x@(NFEqual _ _) = x+    atomic _ = error "Chiou: atomic"+    foldAtoms = foldAtomsFirstOrder+    mapAtoms = mapAtomsFirstOrder++instance (Formula (NormalSentence v p f) (NormalSentence v p f), Combinable (NormalSentence v p f), Term (NormalTerm v f) v f,+          Variable v, Predicate p, Function f v) => FirstOrderFormula (NormalSentence v p f) (NormalSentence v p f) v where     for_all _ _ = error "FirstOrderFormula NormalSentence"     exists _ _ = error "FirstOrderFormula NormalSentence"     foldFirstOrder _ co tf at f =@@ -241,11 +261,12 @@           (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) => Term (NormalTerm v f) v f where+instance (Formula (NormalSentence v p f) (NormalSentence v p f),+          Combinable (NormalSentence v p f), Predicate p, Function f v, Variable v) => HasFixity (NormalSentence v p f) where+    fixity = fixityFirstOrder++instance (Variable v, Function f v) => Term (NormalTerm v f) v f where     vt = NormalVariable     fApp = NormalFunction     foldTerm v f t =@@ -258,17 +279,17 @@           (NormalFunction f1 ts1, NormalFunction f2 ts2) -> fn f1 ts1 f2 ts2           _ -> Nothing -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) =>+toSentence :: (FirstOrderFormula (Sentence v p f) (Sentence v p f) v, Atom (Sentence v p f) (CTerm v f) v, Function f v, Variable v, Predicate p) =>               NormalSentence v p f -> Sentence v p f 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 :: (Variable v, Function f v) => NormalTerm v f -> CTerm v f toTerm (NormalFunction f ts) = fApp f (map toTerm ts) toTerm (NormalVariable v) = vt v -fromSentence :: forall v p f. (FirstOrderFormula (Sentence v p f) (Sentence v p f) v, Arity p, Constants p, Ord p, Ord f, Show p) =>+fromSentence :: forall v p f. (FirstOrderFormula (Sentence v p f) (Sentence v p f) v, Predicate p) =>                 Sentence v p f -> NormalSentence v p f fromSentence = foldFirstOrder                   (\ _ _ _ -> error "fromSentence 1")
Data/Logic/Instances/PropLogic.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, UndecidableInstances #-} {-# OPTIONS -fno-warn-orphans #-} module Data.Logic.Instances.PropLogic     ( flatten@@ -6,13 +6,15 @@     , plSat     ) where +import Data.Logic.Classes.Atom (Atom) 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.Formula (Formula)+import Data.Logic.Classes.Constants (Constants(fromBool, asBool))+import Data.Logic.Classes.FirstOrder (FirstOrderFormula)+import Data.Logic.Classes.Formula (Formula(..)) import Data.Logic.Classes.Literal (Literal(..)) import Data.Logic.Classes.Negate (Negatable(..))-import Data.Logic.Classes.Propositional (PropositionalFormula(..), clauseNormalForm')+import Data.Logic.Classes.Pretty (HasFixity(fixity), Pretty(pretty), topFixity)+import Data.Logic.Classes.Propositional (PropositionalFormula(..), clauseNormalForm', prettyPropositional, fixityPropositional, foldAtomsPropositional, mapAtomsPropositional) import Data.Logic.Classes.Term (Term) import Data.Logic.Harrison.Skolem (SkolemT) import Data.Logic.Normal.Clause (clauseNormalForm)@@ -24,14 +26,18 @@     foldNegation normal inverted (N x) = foldNegation inverted normal x     foldNegation normal _ x = normal x -instance Ord a => Combinable (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 (Combinable (PropForm a), Ord a) => PropositionalFormula (PropForm a) a where+instance (Pretty a, HasFixity a, Ord a) => Formula (PropForm a) a where     atomic = A+    foldAtoms = foldAtomsPropositional+    mapAtoms = mapAtomsPropositional++instance (Combinable (PropForm a), Pretty a, HasFixity a, Ord a) => PropositionalFormula (PropForm a) a where     foldPropositional co tf at formula =         case formula of           -- EJ [x,y,z,...] -> CJ [EJ [x,y], EJ[y,z], ...]@@ -58,7 +64,16 @@ instance Constants (PropForm formula) where     fromBool True = T     fromBool False = F+    asBool T = Just True+    asBool F = Just False+    asBool _ = Nothing +instance (PropositionalFormula (PropForm atom) atom, Pretty atom, HasFixity atom) => Pretty (PropForm atom) where+    pretty = prettyPropositional pretty topFixity++instance (PropositionalFormula (PropForm atom) atom, HasFixity atom) => HasFixity (PropForm atom) where+    fixity = fixityPropositional+ pairs :: [a] -> [(a, a)] pairs (x:y:zs) = (x,y) : pairs (y:zs) pairs _ = []@@ -85,10 +100,13 @@ 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 atom term v f. (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f, Ord formula, Literal formula atom v) =>+plSat :: forall m formula atom term v f. (Monad m, FirstOrderFormula formula atom v, PropositionalFormula formula atom, Atom atom term v, Term term v f, Eq formula, Literal formula atom, Ord formula) =>                 formula -> SkolemT v term m Bool plSat f = clauses f >>= (\ (x :: PropForm formula) -> return x) >>= return . satisfiable -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) =>+clauses :: forall m formula atom term v f.+           (Monad m, FirstOrderFormula formula atom v, PropositionalFormula formula atom, Atom atom term v, Term term v f, Eq formula, Literal formula atom, Ord formula) =>            formula -> SkolemT v term m (PropForm formula)-clauses f = clauseNormalForm f >>= return . CJ . map (DJ . map (toPropositional (A :: formula -> PropForm formula))) . map S.toList . S.toList+clauses f =+    do (cnf :: S.Set (S.Set formula)) <- clauseNormalForm f+       return . CJ . map DJ . map (map A) . map S.toList . S.toList $ cnf
Data/Logic/Instances/SatSolver.hs view
@@ -7,13 +7,13 @@ import Data.Boolean.SatSolver import Data.Generics (Data, Typeable) import qualified Data.Set.Extra as S+import Data.Logic.Classes.Atom (Atom) 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.Negate (Negatable(..), negated, (.~.))+import Data.Logic.Classes.Propositional (PropositionalFormula) import Data.Logic.Classes.Term (Term) import Data.Logic.Normal.Clause (clauseNormalForm) import Data.Logic.Normal.Implicative (LiteralMapT, NormalT)@@ -39,7 +39,14 @@     makeCNF = map S.toList . S.toList     satisfiable cnf = return . not . null $ assertTrue' cnf newSatSolver >>= solve -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) =>+toCNF :: (Monad m,+          FirstOrderFormula formula atom v,+          PropositionalFormula formula atom,+          Atom atom term v,+          AtomEq atom p term,+          Term term v f,+          N.Literal formula atom,+          Ord formula) =>          formula -> NormalT formula v term m CNF toCNF f = clauseNormalForm f >>= S.ssMapM (lift . toLiteral) >>= return . makeCNF
Data/Logic/KnowledgeBase.hs view
@@ -28,12 +28,12 @@ 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.Atom (Atom) import Data.Logic.Classes.Equals (AtomEq) import Data.Logic.Classes.FirstOrder (FirstOrderFormula)-import Data.Logic.Classes.Formula (Formula)-import Data.Logic.Classes.Negate ((.~.)) import Data.Logic.Classes.Literal (Literal)+import Data.Logic.Classes.Negate ((.~.))+import Data.Logic.Classes.Propositional (PropositionalFormula) import Data.Logic.Classes.Term (Term) import Data.Logic.Harrison.Skolem (SkolemT, runSkolemT) import Data.Logic.Normal.Implicative (ImplicativeForm, implicativeNormalForm)@@ -112,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 atom v, FirstOrderFormula lit atom v) => Show (Proof lit) where+instance (Ord lit, Show lit, Literal lit atom, 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@@ -129,8 +129,8 @@ -- |Return a flag indicating whether sentence was disproved, along -- with a disproof. inconsistantKB :: forall m formula atom term v p f lit.-                  (FirstOrderFormula formula atom v, 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) =>+                  (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal lit atom, Atom atom term v, AtomEq atom p term, Term term v f,+                   Monad m, Ord formula, Data formula, Data lit, Eq lit, Ord lit, Ord term) =>                   formula -> ProverT' v term (ImplicativeForm lit) m (Bool, SetOfSupport lit v term) inconsistantKB s =     get >>= \ st ->@@ -142,23 +142,23 @@ -- |Return a flag indicating whether sentence was proved, along with a -- proof. theoremKB :: forall m formula atom term v p f lit.-             (Monad m, FirstOrderFormula formula atom v, 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) =>+             (Monad m, FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal lit atom, Atom atom term v, AtomEq atom p term, Term term v f,+              Ord formula, Ord term, Ord lit, Data formula, Data lit) =>              formula -> ProverT' v term (ImplicativeForm lit) m (Bool, SetOfSupport lit v term) theoremKB s = inconsistantKB ((.~.) s)  -- |Try to prove a sentence, return the result and the proof. -- askKB should be in KnowledgeBase module. However, since resolution -- is here functions are here, it is also placed in this module.-askKB :: (Monad m, FirstOrderFormula formula atom v, 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) =>+askKB :: (Monad m, FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal lit atom, Atom atom term v, AtomEq atom p term, Term term v f,+          Ord formula, Ord term, Ord lit, Data formula, Data lit) =>          formula -> ProverT' v term (ImplicativeForm lit) m Bool askKB s = theoremKB s >>= return . fst  -- |See whether the sentence is true, false or invalid.  Return proofs -- for truth and falsity.-validKB :: (FirstOrderFormula formula atom v, 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) =>+validKB :: (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal lit atom, Atom atom term v, AtomEq atom p term, Term term v f,+            Monad m, Ord formula, Ord term, Ord lit, Data formula, Data lit) =>            formula -> ProverT' v term (ImplicativeForm lit) m (ProofResult, SetOfSupport lit v term, SetOfSupport lit v term) validKB s =     theoremKB s >>= \ (proved, proof1) ->@@ -168,8 +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 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) =>+tellKB :: (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal lit atom, Atom atom term v, AtomEq atom p term, Term term v f,+           Monad m, Ord formula, Data formula, Data lit, Eq lit, Ord lit, Ord term) =>           formula -> ProverT' v term (ImplicativeForm lit) m (Proof lit) tellKB s =     do st <- get@@ -182,8 +182,8 @@                      , sentenceCount = sentenceCount st + 1 }        return $ Proof {proofResult = valid, proof = S.map wiItem inf'} -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) =>+loadKB :: (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal lit atom, Atom atom term v, AtomEq atom p term, Term term v f,+           Monad m, Ord formula, Ord term, Ord lit, Data formula, Data lit) =>           [formula] -> ProverT' v term (ImplicativeForm lit) m [Proof lit] loadKB sentences = mapM tellKB sentences
Data/Logic/Normal/Clause.hs view
@@ -33,15 +33,14 @@     ) where  import Data.List (intersperse)-import Data.Logic.Classes.Constants (Constants(..))+import Data.Logic.Classes.Atom (Atom) 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.Propositional (PropositionalFormula) 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 Data.Logic.Harrison.Skolem (skolemize, SkolemT, pnf, nnf, simplify) import qualified Data.Set.Extra as Set import Text.PrettyPrint (Doc, hcat, vcat, text, nest, ($$), brackets, render) @@ -53,19 +52,33 @@ -- (Q & R) | P  (Q | P) & (R | P) -- @ -- -clauseNormalForm :: (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f, Literal lit atom v, Eq formula, Ord lit) =>+clauseNormalForm :: forall formula atom term v f lit m.+                    (Monad m,+                     FirstOrderFormula formula atom v,+                     PropositionalFormula formula atom,+                     Atom atom term v,+                     Term term v f,+                     Literal lit atom,+                     Ord formula, Ord lit) =>                     formula -> SkolemT v term m (Set.Set (Set.Set lit))-clauseNormalForm fm = skolemNormalForm fm >>= return . simpcnf'+clauseNormalForm fm = skolemize id fm >>= return . (simpcnf' :: formula -> Set.Set (Set.Set lit))  cnfTrace :: forall m formula atom term v p f lit.-            (Monad m, FirstOrderFormula formula atom v, Formula atom term v, AtomEq atom p term, Term term v f, Literal lit atom v, Eq formula, Ord lit, Constants p, Eq p) =>+            (Monad m,+             FirstOrderFormula formula atom v,+             PropositionalFormula formula atom,+             Atom atom term v,+             AtomEq atom p term,+             Term term v f,+             Literal lit atom,+             Ord formula, Ord lit) =>             (v -> Doc)          -> (p -> Doc)          -> (f -> Doc)          -> formula          -> SkolemT v term m (String, Set.Set (Set.Set lit)) cnfTrace pv pp pf f =-    do snf <- skolemNormalForm f+    do (snf :: formula) <- skolemize id f        cnf <- clauseNormalForm f        return (render (vcat                        [text "Original:" $$ nest 2 (prettyFirstOrder (prettyAtomEq pv pp pf) pv 0 f),
Data/Logic/Normal/Implicative.hs view
@@ -16,10 +16,11 @@ 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.Atom (Atom)+import Data.Logic.Classes.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.Propositional (PropositionalFormula)+import Data.Logic.Classes.Skolem (Skolem(isSkolem)) import Data.Logic.Classes.Literal (Literal(..)) import Data.Logic.Classes.Negate (Negatable(..)) import Data.Logic.Classes.Term (Term)@@ -27,7 +28,6 @@ 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@@ -89,15 +89,19 @@ --    a | b | c => f -- @ 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) =>+                         (Monad m,+                          FirstOrderFormula formula atom v,+                          PropositionalFormula formula atom,+                          Atom atom term v,+                          Literal lit atom,+                          Term term v f,+                          Data formula, Ord formula, Ord lit, Data lit, Skolem f v) =>                          formula -> SkolemT v term m (Set.Set (ImplicativeForm lit)) implicativeNormalForm formula =     do cnf <- clauseNormalForm formula        let pairs = Set.map (Set.fold collect (Set.empty, Set.empty)) cnf :: Set.Set (Set.Set lit, Set.Set lit)            pairs' = Set.flatten (Set.map split pairs) :: Set.Set (Set.Set lit, Set.Set lit)        return (Set.map (\ (n,p) -> INF n p) pairs')-    -- clauseNormalForm formula >>= return . Set.unions . Set.map split . map (Set.fold collect (Set.empty, Set.empty))     where       collect :: lit -> (Set.Set lit, Set.Set lit) -> (Set.Set lit, Set.Set lit)       collect f (n, p) =@@ -107,7 +111,7 @@                       f       split :: (Set.Set lit, Set.Set lit) -> Set.Set (Set.Set lit, Set.Set lit)       split (lhs, rhs) =-          if any isJust (map fromSkolem (gFind rhs :: [f]))+          if any isSkolem (gFind rhs :: [f])           then Set.map (\ x -> (lhs, Set.singleton x)) rhs           else Set.singleton (lhs, rhs)
Data/Logic/Resolution.hs view
@@ -13,9 +13,11 @@     , getSubstAtomEq     ) where +import Data.Logic.Classes.Apply (Predicate)+import Data.Logic.Classes.Atom (Atom(isRename, getSubst)) import Data.Logic.Classes.Constants (fromBool) import Data.Logic.Classes.Equals (AtomEq(foldAtomEq, equals), applyEq, zipAtomsEq)-import Data.Logic.Classes.Formula (Formula(isRename, getSubst))+import Data.Logic.Classes.Formula (Formula(atomic)) import Data.Logic.Classes.Literal (Literal(..), zipLiterals) import Data.Logic.Classes.Term (Term(..)) import Data.Logic.Normal.Implicative (ImplicativeForm(INF, neg, pos))@@ -28,7 +30,7 @@  type Unification lit v term = (ImplicativeForm lit, Map.Map v 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) =>+prove :: (Literal lit atom, Atom atom term v, Term term v f, Ord lit, Ord term, Ord v, {-Show v, Show term,-} AtomEq atom p term, Predicate p) =>          Maybe Int -- ^ Recursion limit.  We continue recursing until this                    -- becomes zero.  If it is negative it may recurse until                    -- it overflows the stack.@@ -53,8 +55,9 @@ --         (True, (ss1 ++ [s] ++ss')) --       else --         prove (ss1 ++ [s]) ss' (fst s:kb)+ 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) =>+          (Literal lit atom, Atom 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@@ -66,7 +69,7 @@     in       if S.null ss' then (ss1, False) else (S.union ss1 ss', tf) -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) =>+getResult :: (Literal lit atom, Atom 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@@ -94,20 +97,20 @@ -}  -- |Convert the "question" to a set of support.-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 :: (Literal lit atom, Atom atom term v, Term term v f, Ord lit, Ord term, Ord v) =>+                   S.Set (ImplicativeForm lit) -> S.Set (ImplicativeForm lit, Map.Map v term) getSetOfSupport s = S.map (\ x -> (x, getSubsts x empty)) s -getSubsts :: (Literal formula atom v, Formula atom term v, Term term v f, Ord formula) =>-             ImplicativeForm formula -> Map.Map v term -> Map.Map v term+getSubsts :: (Literal lit atom, Atom atom term v, Term term v f, Ord lit) =>+             ImplicativeForm lit -> Map.Map v term -> Map.Map v term getSubsts inf theta =     getSubstSentences (pos inf) (getSubstSentences (neg inf) theta) -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 :: (Literal lit atom, Atom atom term v, Term term v f) => S.Set lit -> Map.Map v term -> Map.Map v term getSubstSentences xs theta = foldr getSubstSentence theta (S.toList xs)  -getSubstSentence :: (Literal formula atom v, Formula atom term v, Term term v f)  => formula -> Map.Map v term -> Map.Map v term+getSubstSentence :: (Literal lit atom, Atom atom term v, Term term v f)  => lit -> Map.Map v term -> Map.Map v term getSubstSentence formula theta =     foldLiteral           (\ s -> getSubstSentence s theta)@@ -133,7 +136,7 @@              (\ _ ts -> getSubstsTerms ts theta)              term -isRenameOf :: (Literal lit atom v, Formula atom term v, Term term v f, Ord lit) =>+isRenameOf :: (Literal lit atom, Atom atom term v, Term term v f, Ord lit) =>               ImplicativeForm lit -> ImplicativeForm lit -> Bool isRenameOf inf1 inf2 =     (isRenameOfSentences lhs1 lhs2) && (isRenameOfSentences rhs1 rhs2)@@ -143,11 +146,11 @@       lhs2 = neg inf2       rhs2 = pos inf2 -isRenameOfSentences :: (Literal lit atom v, Formula atom term v, Term term v f) => S.Set lit -> S.Set lit -> Bool+isRenameOfSentences :: (Literal lit atom, Atom 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 atom term v f. (Literal formula atom v, Formula atom term v, Term term v f) => formula -> formula -> Bool+isRenameOfSentence :: forall lit atom term v f. (Literal lit atom, Atom atom term v, Term term v f) => lit -> lit -> Bool isRenameOfSentence f1 f2 =     maybe False id $     zipLiterals (\ _ _ -> Just False) (\ x y -> Just (x == y)) (\ x y -> Just (isRename x y)) f1 f2@@ -177,7 +180,7 @@     else       False -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) =>+resolution :: forall lit atom p f term v. (Literal lit atom, Atom atom term v, Term term v f, Eq lit, Ord lit, Eq term, Ord v, AtomEq atom p term, Eq p) =>              (ImplicativeForm lit, Map.Map v term) -> (ImplicativeForm lit, Map.Map v term) -> Maybe (ImplicativeForm lit, Map v term) resolution (inf1, theta1) (inf2, theta2) =     let@@ -199,12 +202,12 @@               Just (INF lhs'' rhs'', theta)         Nothing -> Nothing     where-      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 :: (Literal lit atom, Ord lit) =>+                  S.Set lit -> S.Set lit -> Maybe ((S.Set lit, Map.Map v term), (S.Set lit, Map.Map v term))       tryUnify lhs rhs = tryUnify' lhs rhs S.empty                          -      tryUnify' :: (Literal 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' :: (Literal lit atom, Ord lit) =>+                   S.Set lit -> S.Set lit -> S.Set lit -> Maybe ((S.Set lit, Map.Map v term), (S.Set lit, Map.Map v term))       tryUnify' lhss _ _ | S.null lhss = Nothing       tryUnify' lhss'' rhss lhss' =           let (lhs, lhss) = S.deleteFindMin lhss'' in@@ -213,8 +216,8 @@             Just (rhss', theta1', theta2') ->                 Just ((S.union lhss' lhss, theta1'), (rhss', theta2')) -      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'' :: (Literal lit atom, Ord lit) =>+                    lit -> S.Set lit -> S.Set lit -> Maybe (S.Set lit, Map.Map v term, Map.Map v term)       tryUnify'' _x rhss _ | S.null rhss = Nothing       tryUnify'' x rhss'' rhss' =           let (rhs, rhss) = S.deleteFindMin rhss'' in@@ -223,7 +226,7 @@             Just (theta1', theta2') -> Just (S.union rhss' rhss, theta1', theta2')  -- |Try to unify the second argument using the equality in the first.-demodulate :: (Literal lit atom v, Formula atom term v, Term term v f, Eq lit, Ord lit, Eq term, Ord v, AtomEq atom p term) =>+demodulate :: (Literal lit atom, Atom 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@@ -245,12 +248,12 @@       rhs2 = pos inf2  -- |Unification: unifies two sentences.-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 :: (Literal lit atom, Atom atom term v, Term term v f, AtomEq atom p term, Eq p) =>+         lit -> lit -> Maybe (Map.Map v term, Map.Map v term) unify s1 s2 = unify' s1 s2 empty empty -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' :: (Literal lit atom, Atom atom term v, Term term v f, AtomEq atom p term, Eq p) =>+          lit -> lit -> Map.Map v term -> Map.Map v term -> Maybe (Map.Map v term, Map.Map v term) unify' f1 f2 theta1 theta2 =     zipLiterals          (\ _ _ -> error "unify'")@@ -291,11 +294,11 @@       Just (theta1',theta2') -> unifyTerms ts1 ts2 theta1' theta2' unifyTerms _ _ _ _ = Nothing -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 :: forall lit atom term v p f. (Literal lit atom, Atom atom term v, Term term v f, AtomEq atom p term) =>+             term -> term -> S.Set lit -> 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 (\ (_ :: lit) -> error "getTerms") (\ _ -> []) p) (S.toList s)       unifiedTerms' = map (\t -> unifyTerm tl t empty empty) terms       unifiedTerms = filter isJust unifiedTerms'     in@@ -305,7 +308,7 @@          Just ((substTerm tl theta1, substTerm tr theta1), theta1, theta2)        (Nothing:_) -> error "findUnify"     where-      -- getTerms formula = foldLiteral (\ _ -> error "getTerms") p formula+      -- getTerms lit = foldLiteral (\ _ -> error "getTerms") p formula       p :: atom -> [term]       p = foldAtomEq (\ _ ts -> concatMap getTerms' ts) (const []) (\ t1 t2 -> getTerms' t1 ++ getTerms' t2)       getTerms' :: term -> [term]@@ -321,13 +324,13 @@       p (Apply _ ts) = concatMap getTerms' ts -} -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 :: forall lit atom term v p f. (Literal lit atom, Atom atom term v, Term term v f, Eq term, AtomEq atom p term) => lit -> (term, term) -> Maybe lit replaceTerm formula (tl', tr') =     foldLiteral           (\ _ -> error "error in replaceTerm")-          (\ x -> Just (atomic (applyEq (fromBool x) [])))+          (\ x -> Just (atomic (applyEq (fromBool x) [] :: atom)))           (foldAtomEq (\ p ts -> Just (atomic (applyEq p (map (\ t -> replaceTerm' t) ts))))-                      (\ x -> Just (atomic (applyEq (fromBool x) [])))+                      (\ x -> Just (atomic (applyEq (fromBool x) [] :: atom)))                       (\ t1 t2 ->                             let t1' = replaceTerm' t1                                t2' = replaceTerm' t2 in@@ -341,13 +344,13 @@       termEq t1 t2 =           maybe False id (zipTerms (\ v1 v2 -> Just (v1 == v2)) (\ f1 ts1 f2 ts2 -> Just (f1 == f2 && length ts1 == length ts2 && all (uncurry termEq) (zip ts1 ts2))) t1 t2) -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 :: (Literal formula atom, AtomEq atom p term, Atom atom term v, Term term v f, Eq term) => formula -> Map.Map v term -> Maybe formula subst formula theta =     foldLiteral           (\ _ -> Just formula)-          (\ x -> Just (atomic (applyEq (fromBool x) [])))+          (\ x -> Just (fromBool x))           (foldAtomEq (\ p ts -> Just (atomic (applyEq p (substTerms ts theta))))-                      (\ x -> Just (atomic (applyEq (fromBool x) [])))+                      (Just . fromBool)                       (\ t1 t2 ->                            let t1' = substTerm t1 theta                                t2' = substTerm t2 theta in
Data/Logic/Satisfiable.hs view
@@ -12,10 +12,11 @@     ) where  import qualified Data.Set as Set+import Data.Logic.Classes.Atom (Atom) import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), toPropositional)-import Data.Logic.Classes.Formula (Formula) import Data.Logic.Classes.Literal (Literal) import Data.Logic.Classes.Negate ((.~.))+import Data.Logic.Classes.Propositional (PropositionalFormula) import Data.Logic.Classes.Term (Term) import Data.Logic.Harrison.Skolem (SkolemT) import Data.Logic.Instances.PropLogic ()@@ -23,24 +24,30 @@ import qualified PropLogic as PL  -- |Is there any variable assignment that makes the formula true?-satisfiable :: forall formula atom term v f m. (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f, Ord formula, Literal formula atom v) =>-                formula -> SkolemT 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, Ord atom) =>+--                 formula -> SkolemT v term m Bool+satisfiable :: forall m formula atom v term f. (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal formula atom, Term term v f, Atom atom term v,+                                                Ord atom, Monad m, Eq formula, Ord formula) =>+               formula -> SkolemT v term m Bool satisfiable 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 atom v, Formula atom term v, Term term v f, Ord formula, Literal formula atom v) =>+inconsistant :: forall m formula atom v term f. (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal formula atom, Term term v f, Atom atom term v,+                                                 Ord atom, Monad m, Eq formula, Ord formula) =>                 formula -> SkolemT v term m Bool inconsistant f =  satisfiable f >>= return . not  -- |Is the negation of the formula inconsistant?-theorem :: (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f, Ord formula, Literal formula atom v) =>+theorem :: forall m formula atom v term f. (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal formula atom, Term term v f, Atom atom term v,+                                            Ord atom, Monad m, Eq formula, Ord formula) =>            formula -> SkolemT v term m Bool theorem f = inconsistant ((.~.) f)  -- |A formula is invalid if it is neither a theorem nor inconsistent.-invalid :: (Monad m, FirstOrderFormula formula atom v, Formula atom term v, Term term v f, Ord formula, Literal formula atom v) =>+invalid :: forall m formula atom v term f. (FirstOrderFormula formula atom v, PropositionalFormula formula atom, Literal formula atom, Term term v f, Atom atom term v,+                                            Ord atom, Monad m, Eq formula, Ord formula) =>            formula -> SkolemT v term m Bool invalid f = inconsistant f >>= \ fi -> theorem f >>= \ ft -> return (not (fi || ft))
Data/Logic/Tests/Chiou0.hs view
@@ -27,8 +27,8 @@     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) []])])]),+      expected = [Proof Invalid (S.fromList [makeINF' ([]) ([(pApp ("Dog") [fApp (toSkolem "x") []])]),+                                             makeINF' ([]) ([(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem "x") []])])]),                   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") []])])]),
Data/Logic/Tests/Common.hs view
@@ -1,9 +1,11 @@ -- |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 #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes,+             ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} {-# OPTIONS -Wwarn #-} module Data.Logic.Tests.Common-    ( myTest+    ( render+    , myTest       -- * Formula parameter types     , V(..)     , Pr(..)@@ -29,18 +31,21 @@ import Data.Boolean.SatSolver (CNF) import Data.Char (isDigit) import Data.Generics (Data, Typeable, listify)+import Data.Logic.Classes.Apply (Predicate) import Data.Logic.Classes.Arity (Arity(arity)) import Data.Logic.Classes.ClauseNormalForm (ClauseNormalFormula(satisfiable))-import Data.Logic.Classes.Constants (Constants(..))+import Data.Logic.Classes.Constants (Constants(..), prettyBool) import Data.Logic.Classes.Equals (AtomEq)-import Data.Logic.Classes.FirstOrder (FirstOrderFormula, convertFOF)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula, convertFOF, prettyFirstOrder) 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.Pretty (Pretty(pretty))+import Data.Logic.Classes.Propositional (PropositionalFormula)+import qualified Data.Logic.Classes.Skolem as C+import Data.Logic.Classes.Term (Term(vt, fApp, foldTerm), Function) 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.Harrison.Skolem (Skolem, skolemize, runSkolem, pnf, nnf, simplify)+import qualified Data.Logic.Instances.Chiou as Ch import Data.Logic.Instances.PropLogic (plSat) import qualified Data.Logic.Instances.SatSolver as SS import Data.Logic.KnowledgeBase (WithId, runProver', Proof, loadKB, theoremKB, getKB)@@ -50,12 +55,17 @@ import qualified Data.Logic.Types.FirstOrder as P import qualified Data.Set as S import Data.String (IsString(fromString))+import Text.PrettyPrint (Style(mode), renderStyle, style, Mode(OneLineMode), (<>))  --import PropLogic (PropForm)  import Test.HUnit import Text.PrettyPrint (Doc, text) +-- | Render a Pretty instance in single line mode+render :: Pretty a => a -> String+render = renderStyle (style {mode = OneLineMode}) . pretty+ myTest :: (Show a, Eq a) => String -> a -> a -> Test myTest label expected input =     TestLabel label $ TestCase (assertEqual label expected input)@@ -71,6 +81,9 @@ prettyV :: V -> Doc prettyV (V s) = text s +instance Pretty V where+    pretty = prettyV+ 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@@ -91,12 +104,17 @@     | Equals     deriving (Eq, Ord, Data, Typeable) +instance Predicate Pr+ instance IsString Pr where     fromString = Pr  instance Constants Pr where     fromBool True = T     fromBool False = F+    asBool T = Just True+    asBool F = Just False+    asBool _ = Nothing  instance Arity Pr where     arity (Pr _) = Nothing@@ -111,36 +129,49 @@     show (Pr s) = show s            -- Because Pr is an instance of IsString  prettyP :: Pr -> Doc-prettyP T = text "True"-prettyP F = text "False"+prettyP T = prettyBool True+prettyP F = prettyBool False prettyP Equals = text ".=." prettyP (Pr s) = text s +instance Pretty Pr where+    pretty = prettyP+ data AtomicFunction     = Fn String-    | Skolem Int+    | Skolem V     deriving (Eq, Ord, Data, Typeable) -instance Skolem AtomicFunction where+instance Function AtomicFunction V++instance C.Skolem AtomicFunction V where     toSkolem = Skolem-    fromSkolem (Skolem n) = Just n-    fromSkolem _ = Nothing+    isSkolem (Skolem _) = True+    isSkolem _ = False  instance IsString AtomicFunction where     fromString = Fn  instance Show AtomicFunction where     show (Fn s) = show s-    show (Skolem n) = "toSkolem " ++ show n+    show (Skolem v) = "(toSkolem " ++ show v ++ ")"  prettyF :: AtomicFunction -> Doc prettyF (Fn s) = text s-prettyF (Skolem n) = text ("sK" ++ show n)+prettyF (Skolem v) = text "sK" <> pretty v +instance Pretty AtomicFunction where+    pretty = prettyF+ type TFormula = P.Formula V Pr AtomicFunction type TAtom = P.Predicate Pr TTerm type TTerm = P.PTerm V AtomicFunction +{-+instance Pretty TFormula where+    pretty = prettyFirstOrder (const pretty) pretty 0+-}+ -- |This allows you to use an expression that returns the Doc type in a -- unit test, such as prettyFirstOrder. instance Eq Doc where@@ -160,18 +191,18 @@     | NegationNormalForm formula     | PrenexNormalForm formula     | SkolemNormalForm formula-    | SkolemNumbers (S.Set Int)+    | SkolemNumbers (S.Set AtomicFunction)     | ClauseNormalForm (S.Set (S.Set formula))     | TrivialClauses [(Bool, (S.Set formula))]-    | ConvertToChiou (C.Sentence V Pr AtomicFunction)+    | ConvertToChiou (Ch.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)+deriving instance Show (Ch.Sentence V Pr AtomicFunction)+deriving instance Show (Ch.CTerm V AtomicFunction)  type TTestFormula = TestFormula TFormula TAtom V @@ -189,26 +220,26 @@       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))))+          myTest (name f ++ " skolem normal form") (p f') (p (runSkolem (skolemize id (formula f) :: Skolem V (P.PTerm V AtomicFunction) TFormula)))       doExpected (SkolemNumbers f') =-          myTest (name f ++ " skolem numbers") f' (skolemSet (runSkolem (skolemNormalForm (formula f))))+          myTest (name f ++ " skolem numbers") f' (skolemSet (runSkolem (skolemize id (formula f) :: Skolem V (P.PTerm V AtomicFunction) TFormula)))       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+          let ca :: TAtom -> Ch.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+              ca (P.Apply p ts) = Ch.Predicate p (map ct ts)+              ca (P.Equal t1 t2) = Ch.Equal (ct t1) (ct t2)+              ct :: TTerm -> Ch.CTerm V AtomicFunction               ct = foldTerm cv fn-              cv :: V -> C.CTerm V AtomicFunction+              cv :: V -> Ch.CTerm V AtomicFunction               cv = vt-              fn :: AtomicFunction -> [TTerm] -> C.CTerm V AtomicFunction+              fn :: AtomicFunction -> [TTerm] -> Ch.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)+          myTest (name f ++ " converted to Chiou") result (convertFOF ca id (formula f) :: Ch.Sentence V Pr AtomicFunction)       doExpected (ChiouKB1 result) =           myTest (name f ++ " Chiou KB") result (runProver' Nothing (loadKB [formula f] >>= return . head))       doExpected (PropLogicSat result) =@@ -221,14 +252,30 @@        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+{-+skolemNormalForm' f = (skolem' . nnf . simplify $ f) >>= return . prenex' . nnf' . simplify'++-- skolem' :: formula -> SkolemT v term m pf+skolem' :: ( Monad m+           , Variable v+           , Term term v f+           , FirstOrderFormula formula atom v+           -- , Atom atom term v+           -- , PropositionalFormula pf atom+           -- , Formula formula term v+           ) =>+           formula -> SkolemT v term m pf+skolem' = undefined+-}++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 f 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+      ins :: f -> S.Set f -> S.Set f+      ins f s = if C.isSkolem f+                then S.insert f s+                else 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]) @@ -255,9 +302,10 @@     deriving (Data, Typeable)  doProof :: forall formula atom term v p f. (FirstOrderFormula formula atom v,+                                            PropositionalFormula formula atom,                                             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,+                                            Literal formula atom,                                             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 =
Data/Logic/Tests/Data.hs view
@@ -15,7 +15,7 @@     ) where  import Data.Boolean.SatSolver (Literal(..))-import Data.Generics (Data, Typeable)+--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)@@ -23,14 +23,14 @@ 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 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.Logic.Types.FirstOrder (Predicate(..), PTerm(..)) import Data.Map (fromList) import qualified Data.Set as S import Data.String (IsString)@@ -124,33 +124,33 @@                                 ((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") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("x"))),+                             (pApp2 ("f") (fApp (toSkolem "z") [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") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("x")))),+                             ((.~.) (pApp2 ("f") (fApp (toSkolem "z") [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") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("x"))),+                             (pApp2 ("f") (fApp (toSkolem "z") [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") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("x")))),+                             ((.~.) (pApp2 ("f") (fApp (toSkolem "z") [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 ("f") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("x"))),+                             (pApp2 ("f") (fApp (toSkolem "z") [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"))))]])+                             ((.~.) (pApp2 ("f") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("x")))),+                             ((.~.) (pApp2 ("f") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("y"))))]])                    ]       }     , TestFormula@@ -161,12 +161,12 @@     , TestFormula       { name = "skolemize2"       , formula = exists "x" (for_all "y" (pApp "loves" [x, y]))-      , expected = [SkolemNormalForm (pApp ("loves") [fApp (toSkolem 1) [],y])]+      , expected = [SkolemNormalForm (pApp ("loves") [fApp (toSkolem "x") [],y])]       }     , TestFormula       { name = "skolemize3"       , formula = for_all "y" (exists "x" (pApp "loves" [x, y]))-      , expected = [SkolemNormalForm (pApp ("loves") [fApp (toSkolem 1) [y],y])]+      , expected = [SkolemNormalForm (pApp ("loves") [fApp (toSkolem "x") [y],y])]       }     , TestFormula       { formula = exists "x" (for_all' ["y", "z"]@@ -175,12 +175,12 @@                                 (exists "w"                                  (pApp "P" [x, y, z, u, v, w])))))       , name = "chang example 4.1"-      , expected = [ SkolemNormalForm (pApp "P" [fApp (toSkolem 1) [],+      , expected = [ SkolemNormalForm (pApp "P" [fApp (toSkolem "x") [],                                                  vt ("y"),                                                  vt ("z"),-                                                 fApp (toSkolem 2) [vt ("y"),vt ("z")],+                                                 fApp (toSkolem "u") [vt ("y"),vt ("z")],                                                  vt ("v"),-                                                 fApp (toSkolem 3) [vt ("v"), vt ("y"),vt ("z")]]) ]+                                                 fApp (toSkolem "w") [vt ("v"), vt ("y"),vt ("z")]]) ]       }     , TestFormula       { name = "chang example 4.2"@@ -212,8 +212,8 @@       , 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+          sk1 = f [fApp (toSkolem "x") [x,x,y,z],y]+          sk2 = f [fApp (toSkolem "x") [x,x,y,z],x] in       TestFormula       { name = "distribute bug test"       , formula = ((((.~.) (q [x,y])) .|.@@ -267,9 +267,9 @@       , expected = [ClauseNormalForm                     (toSS                      [[(pApp ("wise") [vt ("y")]),-                       ((.~.) (pApp ("taller") [vt ("y"),fApp (toSkolem 1) [vt ("y")]]))],+                       ((.~.) (pApp ("taller") [vt ("y"),fApp (toSkolem "x") [vt ("y")]]))],                       [(pApp ("wise") [vt ("y")]),-                       ((.~.) (pApp ("wise") [fApp (toSkolem 1) [vt ("y")]]))]])]+                       ((.~.) (pApp ("wise") [fApp (toSkolem "x") [vt ("y")]]))]])]       }     , TestFormula       { name = "cnf test 2"@@ -302,27 +302,27 @@     , TestFormula       { name = "cnf test 6"       , formula = (exists "x" (p0 .=>. pApp "f" [x]))-      , expected = [ClauseNormalForm (toSS [[((.~.) (pApp "p" [])),(pApp "f" [fApp (toSkolem 1) []])]])]+      , expected = [ClauseNormalForm (toSS [[((.~.) (pApp "p" [])),(pApp "f" [fApp (toSkolem "x") []])]])]       }     , let p = pApp "p" []           f' = pApp "f" [x]-          f = pApp "f" [fApp (toSkolem 1) []] in+          f = pApp "f" [fApp (toSkolem "x") []] 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") [])])]+                   , TrivialClauses [(False,S.fromList [((.~.) (pApp ("p") [])),(pApp ("f") [fApp (toSkolem "x") []])]),+                                     (False,S.fromList [((.~.) (pApp ("f") [fApp (toSkolem "x") []])),(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"]])]])]+                    (toSS [[((.~.) (pApp "f" [vt "x",fApp (toSkolem "y") [vt "z"]])),(pApp "f" [vt "x",vt "z"])],+                           [((.~.) (pApp "f" [vt "x",fApp (toSkolem "y") [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 "y") [vt "z"]])]])]       }     , let f = pApp "f"            q = pApp "q"@@ -333,32 +333,32 @@       , 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") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("x"))),+                       (pApp2 ("f") (fApp (toSkolem "z") [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") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("x")))),+                       ((.~.) (pApp2 ("f") (fApp (toSkolem "z") [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") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("x"))),+                       (pApp2 ("f") (fApp (toSkolem "z") [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") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("x")))),+                       ((.~.) (pApp2 ("f") (fApp (toSkolem "z") [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 ("f") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("x"))),+                       (pApp2 ("f") (fApp (toSkolem "z") [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"))))]])+                       ((.~.) (pApp2 ("f") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("x")))),+                       ((.~.) (pApp2 ("f") (fApp (toSkolem "z") [vt ("x"),vt ("y")]) (vt ("y"))))]])                    ]       }     , TestFormula@@ -366,10 +366,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"]]))]])+                     [[(pApp ("p") [vt ("x"),fApp (toSkolem "y") [vt ("x")]]),+                       (pApp ("q") [fApp (toSkolem "y") [vt "x"],fApp (toSkolem "x2") [vt "x"],fApp (toSkolem "z") [vt "x"]])],+                      [(pApp ("p") [vt ("x"),fApp (toSkolem "y") [vt ("x")]]),+                       ((.~.) (pApp ("r") [fApp (toSkolem "y") [vt "x"]]))]])                    ]       }     , TestFormula@@ -377,8 +377,8 @@       , 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"])]])]+                    [[((.~.) (pApp "p" [vt "x",vt "z"])),((.~.) (pApp "q" [vt "x",fApp (toSkolem "y") [vt "x",vt "z"]]))],+                     [((.~.) (pApp "p" [vt "x",vt "z"])),(pApp "r" [fApp (toSkolem "y") [vt "x",vt "z"],vt "z"])]])]       }     , TestFormula       { name = "cnf test 12"@@ -431,8 +431,8 @@                        ((((.~.) (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+          fv = fApp (toSkolem "v") [u,x]+          fy = fApp (toSkolem "y") [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]]))))@@ -443,7 +443,7 @@       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))))) ] }+      , expected = [ SkolemNormalForm (((.~.) (p x)) .|. (q (fApp (toSkolem "y") []) .|. (((.~.) (p z)) .|. ((.~.) (q z))))) ] }     ]  animalKB :: (String, [TTestFormula])@@ -463,7 +463,7 @@     , [ 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) []])]])]+       , expected = [ClauseNormalForm (toSS [[(pApp "Dog" [fApp (toSkolem "x") []])],[(pApp "Owns" [fApp "Jack" [],fApp (toSkolem "x") []])]])]        -- owns(jack,sK0)        -- dog (SK0)                    }@@ -552,10 +552,10 @@                 ((.~.) (pApp ("Dog") [vt ("y")])),                 ((.~.) (pApp ("Owns") [vt ("x"),vt ("y")]))],                [(pApp ("Cat") [fApp ("Tuna") []])],-               [(pApp ("Dog") [fApp (toSkolem 1) []])],+               [(pApp ("Dog") [fApp (toSkolem "x") []])],                [(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []]),                 (pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])],-               [(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem 1) []])],+               [(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem "x") []])],                [((.~.) (pApp ("Animal") [vt ("y")])),                 ((.~.) (pApp ("AnimalLover") [vt ("x")])),                 ((.~.) (pApp ("Kills") [vt ("x"),vt ("y")]))],@@ -565,9 +565,9 @@               Invalid               (S.fromList                 [makeINF' ([]) ([(pApp ("Cat") [fApp ("Tuna") []])]),-                makeINF' ([]) ([(pApp ("Dog") [fApp (toSkolem 1) []])]),+                makeINF' ([]) ([(pApp ("Dog") [fApp (toSkolem "x") []])]),                 makeINF' ([]) ([(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []]),(pApp ("Kills") [fApp ("Jack") [],fApp ("Tuna") []])]),-                makeINF' ([]) ([(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem 1) []])]),+                makeINF' ([]) ([(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem "x") []])]),                 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")])]),@@ -580,8 +580,8 @@        , expected =            [ ClauseNormalForm              (toSS-             [[(pApp "Dog" [fApp (toSkolem 1) []])],-              [(pApp "Owns" [fApp ("Jack") [],fApp (toSkolem 1) []])],+             [[(pApp "Dog" [fApp (toSkolem "x") []])],+              [(pApp "Owns" [fApp ("Jack") [],fApp (toSkolem "x") []])],               [((.~.) (pApp "Dog" [vt ("y")])),                ((.~.) (pApp "Owns" [vt ("x"),vt ("y")])),                (pApp "AnimalLover" [vt ("x")])],@@ -642,8 +642,8 @@                                                 ((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"]]))]]+                                          [(pApp "Socrates" [fApp (toSkolem "x") [vt "x2",vt "x2"]])],+                                          [((.~.) (pApp "Mortal" [fApp (toSkolem "x") [vt "x2",vt "x2"]]))]]                     , SatPropLogic True ]        }      , TestFormula@@ -656,8 +656,8 @@                     -- [~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]]))]]+                                         [((.~.) (pApp "Socrates" [fApp (toSkolem "x") [x,y]])), (pApp "Human" [fApp (toSkolem "x") [x,y]])],+                                         [(pApp "Socrates" [fApp (toSkolem "x") [x,y]])], [((.~.) (pApp "Mortal" [fApp (toSkolem "x") [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"])]] ]@@ -768,7 +768,7 @@                                     (((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"),fApp (toSkolem "z") [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")])))) .|.@@ -781,15 +781,15 @@                              ((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])+                       (((pApp ("P") [fApp (toSkolem "x") [],fApp (toSkolem "x") [],fApp ("e") []]) .&.+                         (((pApp ("P") [fApp (toSkolem "u") [],fApp (toSkolem "v") [],fApp (toSkolem "w") []]) .&.+                           (((.~.) (pApp ("P") [fApp (toSkolem "v") [],fApp (toSkolem "u") [],fApp (toSkolem "w") []]))))))))+                    , SkolemNumbers (S.fromList [toSkolem "u",toSkolem "v",toSkolem "w",toSkolem "x",toSkolem "z"])                     -- From our algorithm                      , ClauseNormalForm                       (toSS -                      [[(pApp ("P") [vt ("x"),vt ("y"),fApp (toSkolem 1) [vt ("x"),vt ("y")]])],+                      [[(pApp ("P") [vt ("x"),vt ("y"),fApp (toSkolem "z") [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")])),@@ -802,18 +802,18 @@                        [(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) []]))]])+                       [(pApp ("P") [fApp (toSkolem "x") [],fApp (toSkolem "x") [],fApp ("e") []])],+                       [(pApp ("P") [fApp (toSkolem "u") [],fApp (toSkolem "v") [],fApp (toSkolem "w") []])],+                       [((.~.) (pApp ("P") [fApp (toSkolem "v") [],fApp (toSkolem "u") [],fApp (toSkolem "w") []]))]])                      -- 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+                              (fApp (toSkolem "x") [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 "x") [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 "x") [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",fApp (toSkolem "x") [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"])),@@ -877,12 +877,12 @@                               ((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+                    , let a = fApp (toSkolem "u3") []+                          b = fApp (toSkolem "v3") []+                          c = fApp (toSkolem "w3") [] in                       ClauseNormalForm                       (toSS-                      [[(pApp ("P") [vt ("x"),vt ("y"),fApp (toSkolem 1) [vt ("x"),vt ("y")]])],+                      [[(pApp ("P") [vt ("x"),vt ("y"),fApp (toSkolem "z") [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")])),@@ -895,7 +895,7 @@                        [(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 "x8") [],fApp (toSkolem "x8") [],fApp ("e") []])],                        [(pApp ("P") [a,b,c])],                        [((.~.) (pApp ("P") [b,a,c]))]])                                           ]@@ -944,8 +944,8 @@       , 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 []) (S.fromList [(pApp "Dog" [fApp (toSkolem "x") []])]), wiIdent = 1},+                      WithId {wiItem = INF (S.fromList []) (S.fromList [(pApp "Owns" [fApp "Jack" [],fApp (toSkolem "x") []])]), 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},@@ -958,12 +958,12 @@                            (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 "Animal" [fApp "Tuna" []]),(pApp "Owns" [fApp "Curiosity" [],fApp (toSkolem "x") []])] [],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 "Cat" [fApp "Tuna" []]),(pApp "Owns" [fApp "Curiosity" [],fApp (toSkolem "x") []])] [],fromList []),                            (inf' [(pApp "Dog" [vt "y"]),(pApp "Owns" [fApp "Curiosity" [],vt "y"])] [],fromList []),-                           (inf' [(pApp "Owns" [fApp "Curiosity" [],fApp (toSkolem 1) []])] [],fromList [])]))+                           (inf' [(pApp "Owns" [fApp "Curiosity" [],fApp (toSkolem "x") []])] [],fromList [])]))           ]       }     , TestProof@@ -972,8 +972,8 @@       , 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" [fApp (toSkolem "x") []])],                 wiIdent = 1},+                      WithId {wiItem = inf' []                                 [(pApp "Owns" [fApp "Jack" [],fApp (toSkolem "x") []])], 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"]),@@ -990,14 +990,14 @@                           (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 ("Animal") [fApp ("Tuna") []]),(pApp ("Dog") [fApp (toSkolem "x") []])]) ([]),fromList []),+                          (makeINF' ([(pApp ("Animal") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem "x") []])]) ([]),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 ("Cat") [fApp ("Tuna") []]),(pApp ("Dog") [fApp (toSkolem "x") []])]) ([]),fromList []),+                          (makeINF' ([(pApp ("Cat") [fApp ("Tuna") []]),(pApp ("Owns") [fApp ("Jack") [],fApp (toSkolem "x") []])]) ([]),fromList []),                           (makeINF' ([(pApp ("Dog") [vt ("y")]),(pApp ("Owns") [fApp ("Jack") [],vt ("y")])]) ([]),fromList []),                           (makeINF' ([(pApp ("Kills") [fApp ("Curiosity") [],fApp ("Tuna") []])]) ([]),fromList [])])           ]@@ -1025,10 +1025,10 @@          , 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 [])])]+                         (makeINF' ([]) ([(pApp ("Human") [fApp (toSkolem "x") []])]),fromList []),+                         (makeINF' ([]) ([(pApp ("Mortal") [fApp (toSkolem "x") []])]),fromList []),+                         (makeINF' ([]) ([(pApp ("Socrates") [fApp (toSkolem "x") []])]),fromList []),+                         (makeINF' ([(pApp ("Mortal") [fApp (toSkolem "x") []])]) ([]),fromList [])])]       }     , let x = vt "x" in       TestProof@@ -1052,9 +1052,9 @@                     [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 []),+                        S.fromList [(makeINF' ([]) ([(pApp ("Human") [fApp (toSkolem "x") []])]),fromList []),+                                    (makeINF' ([]) ([(pApp ("Mortal") [fApp (toSkolem "x") []])]),fromList []),+                                    (makeINF' ([]) ([(pApp ("Socrates") [fApp (toSkolem "x") []])]),fromList []),                                     (makeINF' ([(pApp ("Socrates") [vt ("x")])]) ([(pApp ("Mortal") [vt ("x")])]),fromList [("x",vt ("x"))])])          ]       }
+ Data/Logic/Tests/HUnit.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE MultiParamTypeClasses, RankNTypes #-}+module Data.Logic.Tests.HUnit+    ( Test(..)+    , Assertion+    , T.assertEqual+    , convert+    , TestFormula+    , TestFormulaEq+    ) where++import Data.Logic.Classes.Apply (Apply)+import Data.Logic.Classes.Equals (AtomEq)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula)+import Data.Logic.Classes.Term (Term)+import Data.Logic.Types.Harrison.FOL (Function(..))+import Data.String (IsString(fromString))+import qualified Test.HUnit as T++type Assertion t = IO ()++-- | HUnit Test type with an added phantom type parameter.  To run+-- such a test you use the convert function below:+-- @+--   :load Data.Logic.Tests.Harrison.Meson+--   :m +Data.Logic.Tests.HUnit+--   :m +Test.HUnit+--   runTestTT (convert tests)+-- @+data Test t+  = TestCase (Assertion t)+  | TestList [Test t]+  | TestLabel String (Test t)+  | Test0 T.Test++convert :: Test t -> T.Test+convert (TestCase assertion) = T.TestCase assertion+convert (TestList tests) = T.TestList (map convert tests)+convert (TestLabel label test) = T.TestLabel label (convert test)+convert (Test0 test) = test++class (FirstOrderFormula formula atom v,+       Apply atom p term,+       Term term v f,+       Eq formula, Ord formula, Show formula,+       Eq p,+       IsString v, IsString p, IsString f, Ord f, Ord p,+       Eq term, Show term, Ord term,+       Show v) => TestFormula formula atom term v p f++class (FirstOrderFormula formula atom v,+       AtomEq atom p term,+       Term term v f,+       Eq formula, Ord formula, Show formula,+       Eq p,+       IsString v, IsString p, IsString f, Ord f, Ord p,+       Eq term, Show term, Ord term,+       Show v) => TestFormulaEq formula atom term v p f++{-+type Test' = forall formula atom term v p f. TestFormula formula atom term v p f => Test formula+type Formula' = forall formula atom term v p f. TestFormula formula atom term v p f => formula+type TestEq' = forall formula atom term v p f. TestFormulaEq formula atom term v p f => Test formula+type FormulaEq' = forall formula atom term v p f. TestFormulaEq formula atom term v p f => formula+-}++instance IsString Function where+    fromString = FName
+ Data/Logic/Tests/Harrison/Common.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE FlexibleInstances, StandaloneDeriving #-}+module Data.Logic.Tests.Harrison.Common where++import Data.Logic.Types.Harrison.Equal (FOLEQ(..))+import Data.Logic.Types.Harrison.Formulas.FirstOrder (Formula(..))++deriving instance Show FOLEQ+deriving instance Show (Formula FOLEQ)++
Data/Logic/Tests/Harrison/Equal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables, TypeSynonymInstances #-} {-# OPTIONS_GHC -Wall #-} module Data.Logic.Tests.Harrison.Equal where @@ -10,21 +10,23 @@  import Control.Applicative.Error (Failing(..)) import Data.Logic.Classes.Combine (Combinable(..), (∧), (⇒))+--import Data.Logic.Classes.Constants (true) import Data.Logic.Classes.Equals ((.=.), pApp) import Data.Logic.Classes.FirstOrder ((∃), (∀))+--import Data.Logic.Classes.Pretty (Pretty(pretty)) 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.Tests.Common (render) 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+import Data.Logic.Tests.HUnit  -- type TF = TestFormula (Formula FOL) FOL TermType String String Function -- type TFE = TestFormulaEq (Formula FOLEQ) FOLEQ TermType String String Function@@ -69,29 +71,67 @@ 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+test02 = test "equalitize 1 (p. 241)" (expected, expectedProof) input+    where input = (render ewd, runSkolem (meson (Just 10) ewd))+          ewd = equalitize fm :: Formula FOLEQ           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"+          fm = ((∀) "x" (fx ⇒ gx)) ∧+               ((∃) "x" fx) ∧+               ((∀) "x" ((∀) "y" (gx ∧ gy ⇒ x .=. y))) ⇒+               ((∀) "y" (gy ⇒ fy))+          fx = pApp' "f" [x]+          gx = pApp' "g" [x]+          fy = pApp' "f" [y]+          gy = pApp' "g" [y]+          x = vt "x"+          y = vt "y"+          z = vt "z"+          x1 = vt "x1"+          y1 = vt "y1"+          fx1 = pApp' "f" [x1]+          gx1 = pApp' "g" [x1]+          fy1 = pApp' "f" [y1]+          gy1 = pApp' "g" [y1]           -- y1 = fromString "y1"           -- z = fromString "z"-          expected =+          expected = render $+              ((∀) "x" (x .=. x)) .&.+              ((∀) "x" ((∀) "y" ((∀) "z" (x .=. y .&. x .=. z .=>. y .=. z)))) .&.+              ((∀) "x1" ((∀) "y1" (x1 .=. y1 .=>. fx1 .=>. fy1))) .&.+              ((∀) "x1" ((∀) "y1" (x1 .=. y1 .=>. gx1 .=>. gy1))) .=>.+              ((∀) "x" (fx .=>. gx)) .&.+              ((∃) "x" (fx)) .&.+              ((∀) "x" ((∀) "y" (gx .&. gy .=>. x .=. y))) .=>.+              ((∀) "y" (gy .=>. fy))+{-+          -- I don't yet know if this is right.  Almost certainly not.+          expectedProof = Set.fromList [Success ((Map.fromList [("_0",vt "_1")],0,2),1),+                                        Success ((Map.fromList [("_0",vt "_2"),("_1",vt "_2")],0,3),1),+                                        Success ((Map.fromList [("_0",fApp (Skolem 1) [] :: TermType)],0,1),1),+                                        Success ((Map.fromList [("_0",fApp (Skolem 2) [] :: TermType)],0,1),1)]++          expected = ("<<(forall x. x = x) /\ " +++                      "    (forall x y z. x = y /\ x = z ==> y = z) /\ " +++                      "    (forall x1 y1. x1 = y1 ==> f(x1) ==> f(y1)) /\ " +++                      "    (forall x1 y1. x1 = y1 ==> g(x1) ==> g(y1)) ==> " +++                      "    (forall x. f(x) ==> g(x)) /\ " +++                      "    (exists x. f(x)) /\ (forall x y. g(x) /\ g(y) ==> x = y) ==> " +++                      "    (forall y. g(y) ==> f(y))>> ")+-}+          expectedProof =+              Set.fromList [Success ((Map.fromList [(fromString "_0",vt "_2"),+                                                    (fromString "_1",fApp (toSkolem "y") []),+                                                    (fromString "_2",vt "_4"),+                                                    (fromString "_3",fApp (toSkolem "y") []),+                                                    (fromString "_4",fApp (toSkolem "x") [])],0,5),6)]+{-+          expectedProof =               Set.singleton (Success ((Map.fromList [(fromString "_0",vt' "_2"),-                                                     (fromString "_1",fApp (toSkolem 1) []),+                                                     (fromString "_1",fApp (toSkolem "x") []),                                                      (fromString "_2",vt' "_4"),-                                                     (fromString "_3",fApp (toSkolem 1) []),-                                                     (fromString "_4",fApp (toSkolem 2) []),-                                                     (fromString "_5",fApp (toSkolem 1) [])], 0, 6), 5))-{-+                                                     (fromString "_3",fApp (toSkolem "x") []),+                                                     (fromString "_4",fApp (toSkolem "x") []),+                                                     (fromString "_5",fApp (toSkolem "x") [])], 0, 6), 5))           fApp' :: String -> [term] -> term           fApp' s ts = fApp (fromString s) ts           for_all' s = for_all (fromString s)@@ -99,36 +139,62 @@ -}           pApp' :: String -> [TermType] -> Formula FOLEQ           pApp' s ts = pApp (fromString s :: PredName) ts-          vt' :: String -> TermType-          vt' s = vt (fromString s)+          --vt' :: String -> TermType+          --vt' s = vt (fromString s)  -- -------------------------------------------------------------------------  -- Wishnu Prasetya's example (even nicer with an "exists unique" primitive).  -- -------------------------------------------------------------------------  +wishnu :: Formula FOLEQ+wishnu = ((∃) ("x") ((x .=. f[g[x]]) ∧ (∀) ("x'") ((x' .=. f[g[x']]) ⇒ (x .=. x')))) .<=>.+         ((∃) ("y") ((y .=. g[f[y]]) ∧ (∀) ("y'") ((y' .=. g[f[y']]) ⇒ (y .=. y'))))+    where+      x = vt "x"+      y = vt "y"+      x' = vt "x'"+      y' = vt "y"+      f terms = fApp (fromString "f") terms+      g terms = fApp (fromString "g") terms+ 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")+test03 = TestLabel "equalitize 2" $ TestCase $ assertEqual "equalitize 2 (p. 241)" (render expected, expectedProof) input+    where -- This depth is not sufficient to finish. It shoudl work with 16, but that takes a long time.+          input = (render (equalitize wishnu), runSkolem (meson (Just 50) wishnu))+          x = vt "x" :: TermType+          x1 = vt "x1"+          y = vt "y"+          y1 = vt "y1"+          z = vt "z"+          x' = vt "x'"+          y' = vt "y"           f terms = fApp (fromString "f") terms           g terms = fApp (fromString "g") terms-          expected = Set.singleton (Failure ["Exceeded maximum depth limit"])+          expected :: Formula FOLEQ+          expected =+                     ((∀) "x" (x .=. x)) .&.+                     ((∀) "x" . (∀) "y" . (∀) "z" $ (x .=. y .&. x .=. z .=>. y .=. z)) .&.+                     ((∀) "x1" . (∀) "y1" $ (x1 .=. y1 .=>. f[x1] .=. f[y1])) .&.+                     ((∀) "x1" . (∀) "y1" $ (x1 .=. y1 .=>. g[x1] .=. g[y1])) .=>.+                     (((∃) "x" $ x .=. f[g[x]] .&. ((∀) "x'" $ (x' .=. f[g[x']] .=>. x .=. x'))) .<=>.+                      ((∃) "y" $ y .=. g[f[y]] .&. ((∀) "y'" $ (y' .=. g[f[y']] .=>. y .=. y'))))+          expectedProof =+              Set.fromList [Failure ["Exceeded maximum depth limit"]]+{-+              Set.fromList [Success ((Map.fromList [("_0",vt "_1")],0,2 :: Map.Map String TermType),1),+                            Success ((Map.fromList [("_0",vt "_1"),("_1",fApp "f" [fApp "g" [vt "_0"]])],0,2),1),+                            Success ((Map.fromList [("_0",vt "_1"),("_1",fApp "g" [fApp "f" [vt "_0"]])],0,2),1),+                            Success ((Map.fromList [("_0",vt "_1"),("_2",fApp (fromSkolem 2) [vt "_0"])],0,3),1),+                            Success ((Map.fromList [("_0",vt "_2"),("_1",vt "_2")],0,3),1)] -}  -- -------------------------------------------------------------------------  -- More challenging equational problems. (Size 18, 61814 seconds.)            -- -------------------------------------------------------------------------   test04 :: Test (Formula FOLEQ)-test04 = test "equalitize 3 (p. 248)" expected input+test04 = test "equalitize 3 (p. 248)" (render expected, expectedProof) input     where-      input = runSkolem (meson (Just 20) . equalitize $ fm)+      input = (render (equalitize fm), runSkolem (meson (Just 20) . equalitize $ fm))       fm :: Formula FOLEQ       fm = ((∀) "x" . (∀) "y" . (∀) "z") ((*) [x', (*) [y', z']] .=. (*) [((*) [x', y']), z']) ∧            (∀) "x" ((*) [one, x'] .=. x') ∧@@ -140,14 +206,25 @@       (*) = fApp (fromString "*")       i = fApp (fromString "i")       one = fApp (fromString "1") []-      expected :: Set.Set (Failing ((Map.Map String TermType, Int, Int), Int))+      expected :: Formula FOLEQ       expected =+          ((∀) "x" ((vt "x") .=. (vt "x")) .&.+           ((∀) "x" ((∀) "y" ((∀) "z" ((((vt "x") .=. (vt "y")) .&. ((vt "x") .=. (vt "z"))) .=>. ((vt "y") .=. (vt "z"))))) .&.+            ((∀) "x1" ((∀) "x2" ((∀) "y1" ((∀) "y2" ((((vt "x1") .=. (vt "y1")) .&. ((vt "x2") .=. (vt "y2"))) .=>.+                                                                     ((fApp "*" [vt "x1",vt "x2"]) .=. (fApp "*" [vt "y1",vt "y2"])))))) .&.+             (∀) "x1" ((∀) "y1" (((vt "x1") .=. (vt "y1")) .=>. ((fApp "i" [vt "x1"]) .=. (fApp "i" [vt "y1"]))))))) .=>.+          ((((∀) "x" ((∀) "y" ((∀) "z" ((fApp "*" [vt "x",fApp "*" [vt "y",vt "z"]]) .=. (fApp "*" [fApp "*" [vt "x",vt "y"],vt "z"])))) .&.+             (∀) "x" ((fApp "*" [fApp "1" [],vt "x"]) .=. (vt "x"))) .&.+            (∀) "x" ((fApp "*" [fApp "i" [vt "x"],vt "x"]) .=. (fApp "1" []))) .=>.+           (∀) "x" ((fApp "*" [vt "x",fApp "i" [vt "x"]]) .=. (fApp "1" [])))+      expectedProof :: Set.Set (Failing ((Map.Map String TermType, Int, Int), Int))+      expectedProof =           Set.fromList                  [Success ((Map.fromList                                    [( "_0",  (*) [one, vt' "_3"]),-                                    ( "_1",  (*) [fApp (toSkolem 1) [],i [fApp (toSkolem 1) []]]),+                                    ( "_1",  (*) [fApp (toSkolem "x") [],i [fApp (toSkolem "x") []]]),                                     ( "_2",  one),-                                    ( "_3",  (*) [fApp (toSkolem 1) [],i [fApp (toSkolem 1) []]]),+                                    ( "_3",  (*) [fApp (toSkolem "x") [],i [fApp (toSkolem "x") []]]),                                     ( "_4",  vt' "_8"),                                     ( "_5",  (*) [one, vt' "_3"]),                                     ( "_6",  one),@@ -166,11 +243,11 @@                                     ("_19", vt' "_20"),                                     ("_20", i [vt' "_28"]),                                     ("_21", vt' "_28"),-                                    ("_22", fApp (toSkolem 1) []),-                                    ("_23", i [fApp (toSkolem 1) []]),+                                    ("_22", fApp (toSkolem "x") []),+                                    ("_23", i [fApp (toSkolem "x") []]),                                     ("_24", (*) [vt' "_13", vt' "_14"]),                                     ("_25", (*) [vt' "_22", vt' "_23"]),-                                    ("_26", (*) [fApp (toSkolem 1) [],i [fApp (toSkolem 1) []]]),+                                    ("_26", (*) [fApp (toSkolem "x") [],i [fApp (toSkolem "x") []]]),                                     ("_27", one),                                     ("_28", vt' "_30"),                                     ("_29", (*) [vt' "_22", vt' "_23"]),
Data/Logic/Tests/Harrison/FOL.hs view
@@ -14,7 +14,7 @@ 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.Constants (false) import Data.Logic.Classes.Equals (AtomEq(..), (.=.)) import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..)) import qualified Data.Logic.Classes.FirstOrder as C@@ -22,7 +22,7 @@ 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.Tests.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(..))
− Data/Logic/Tests/Harrison/HUnit.hs 
@@ -1,61 +0,0 @@-{-# 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
@@ -1,9 +1,7 @@ {-# 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 Data.Logic.Classes.Pretty (pretty) 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@@ -15,13 +13,16 @@ 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 Data.Logic.Tests.HUnit import qualified Test.HUnit as T-import Data.String (IsString)+--import Data.String (IsString)  instance TestFormula (Formula FOL) FOL TermType String String Function instance TestFormulaEq (Formula FOLEQ) FOLEQ TermType String PredName Function +instance Show (Formula FOL) where+    show = show . pretty+ main = T.runTestTT tests  tests :: T.Test@@ -35,5 +36,5 @@          , Skolem.tests          , convert (Resolution.tests :: Test (Formula FOLEQ))          , convert (Equal.tests :: Test (Formula FOLEQ))-         , convert (Meson.test01 :: Test (Formula FOLEQ))+         , convert (Meson.tests :: Test (Formula FOLEQ))          ]
Data/Logic/Tests/Harrison/Meson.hs view
@@ -1,22 +1,34 @@-{-# LANGUAGE FlexibleContexts, RankNTypes, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings, 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.Equals (pApp)+import Data.Logic.Classes.Combine ((.&.), (.=>.), (.|.))+import Data.Logic.Classes.Constants (true)+import Data.Logic.Classes.FirstOrder (exists, for_all)+import Data.Logic.Classes.Negate ((.~.)) import Data.Logic.Classes.Skolem (Skolem(..)) import Data.Logic.Classes.Term (Term(vt, fApp))+import Data.Logic.Harrison.FOL (generalize, list_conj) import Data.Logic.Harrison.Meson(meson)-import Data.Logic.Harrison.Skolem (runSkolem)+import Data.Logic.Harrison.Normal (simpdnf)+import Data.Logic.Harrison.Skolem (runSkolem, askolemize)+import Data.Logic.Tests.Common (render) import Data.Logic.Tests.Harrison.Resolution (dpExampleFm)-import Data.Logic.Tests.Harrison.HUnit+import Data.Logic.Tests.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) +tests :: Test (Formula FOLEQ)+tests = TestLabel "Data.Logic.Tests.Harrison.Meson" $+        TestList [test01, test02]+ -- -------------------------------------------------------------------------  -- Example.                                                                   -- ------------------------------------------------------------------------- @@ -28,19 +40,84 @@                                     -- 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)+                                                            (fromString "_10",fApp (toSkolem "z") [vt' "_6",vt' "_7"]),+                                                            (fromString "_11",fApp (toSkolem "z") [vt' "_6",vt' "_7"]),+                                                            (fromString "_12",fApp (toSkolem "z") [vt' "_0",vt' "_1"]),+                                                            (fromString "_13",fApp (toSkolem "z") [vt' "_0",vt' "_1"]),+                                                            (fromString "_14",fApp (toSkolem "z") [vt' "_0",vt' "_1"]),+                                                            (fromString "_15",fApp (toSkolem "z") [vt' "_12",vt' "_13"]),+                                                            (fromString "_16",fApp (toSkolem "z") [vt' "_12",vt' "_13"]),+                                                            (fromString "_17",fApp (toSkolem "z") [vt' "_12",vt' "_13"]),+                                                            (fromString "_3",fApp (toSkolem "z") [vt' "_0",vt' "_1"]),+                                                            (fromString "_4",fApp (toSkolem "z") [vt' "_0",vt' "_1"]),+                                                            (fromString "_5",fApp (toSkolem "z") [vt' "_0",vt' "_1"]),+                                                            (fromString "_7",fApp (toSkolem "z") [vt' "_0",vt' "_1"]),+                                                            (fromString "_8",fApp (toSkolem "z") [vt' "_0",vt' "_1"]),+                                                            (fromString "_9",fApp (toSkolem "z") [vt' "_6",vt' "_7"])],0,18),8)                                    )           vt' = vt . fromString++test02 :: Test (Formula FOLEQ)+test02 =+    TestLabel "Data.Logic.Tests.Harrison.Meson" $+    TestList [TestCase (assertEqual "meson dp example, step 1 (p. 220)"+                                    (render (exists "x" (exists "y" (for_all "z" (((f [x,y]) .=>. ((f [y,z]) .&. (f [z,z]))) .&.+                                                                                  (((f [x,y]) .&. (g [x,y])) .=>. ((g [x,z]) .&. (g [z,z]))))))))+                                    (render dpExampleFm)),+              TestCase (assertEqual "meson dp example, step 2 (p. 220)"+                                    (render (exists "x" (exists "y" (for_all "z" (((f [x,y]) .=>. ((f [y,z]) .&. (f [z,z]))) .&.+                                                                                  (((f [x,y]) .&. (g [x,y])) .=>. ((g [x,z]) .&. (g [z,z]))))))))+                                    (render (generalize dpExampleFm))),+              TestCase (assertEqual "meson dp example, step 3 (p. 220)"+                                    (render ((.~.)(exists "x" (exists "y" (for_all "z" (((f [x,y]) .=>. ((f [y,z]) .&. (f [z,z]))) .&.+                                                                                        (((f [x,y]) .&. (g [x,y])) .=>. ((g [x,z]) .&. (g [z,z]))))))) :: Formula FOLEQ))+                                    (render ((.~.) (generalize dpExampleFm)))),+              TestCase (assertEqual "meson dp example, step 4 (p. 220)"+                                    (render (for_all "x" . for_all "y" $+                                             f[x,y] .&.+                                             ((.~.)(f[y, sk1[x, y]]) .|. ((.~.)(f[sk1[x,y], sk1[x, y]]))) .|.+                                             (f[x,y] .&. g[x,y]) .&.+                                             (((.~.)(g[x,sk1[x,y]])) .|. ((.~.)(g[sk1[x,y], sk1[x,y]])))))+                                    (render (runSkolem (askolemize ((.~.) (generalize dpExampleFm))) :: Formula FOLEQ))),+              TestCase (assertEqual "meson dp example, step 5 (p. 220)"+                                    (Set.map (Set.map render)+                                     (Set.fromList+                                      [Set.fromList [for_all "x" . for_all "y" $+                                                     f[x,y] .&.+                                                     ((.~.)(f[y, sk1[x, y]]) .|. ((.~.)(f[sk1[x,y], sk1[x, y]]))) .|.+                                                     (f[x,y] .&. g[x,y]) .&.+                                                     (((.~.)(g[x,sk1[x,y]])) .|. ((.~.)(g[sk1[x,y], sk1[x,y]])))]]))+{-+[[<<forall x y.+      F(x,y) /\+      (~F(y,f_z(x,y)) \/ ~F(f_z(x,y),f_z(x,y))) \/+      (F(x,y) /\ G(x,y)) /\+      (~G(x,f_z(x,y)) \/ ~G(f_z(x,y),f_z(x,y))) >>]]+-}+                                    (Set.map (Set.map render) (simpdnf (runSkolem (askolemize ((.~.) (generalize dpExampleFm))) :: Formula FOLEQ)))),+              TestCase (assertEqual "meson dp example, step 6 (p. 220)"+                                    (Set.map render+                                     (Set.fromList [for_all "x" . for_all "y" $+                                                    f[x,y] .&.+                                                    ((.~.)(f[y, sk1[x, y]]) .|. ((.~.)(f[sk1[x,y], sk1[x, y]]))) .|.+                                                    (f[x,y] .&. g[x,y]) .&.+                                                    (((.~.)(g[x,sk1[x,y]])) .|. ((.~.)(g[sk1[x,y], sk1[x,y]])))]))+{-+[<<forall x y.+     F(x,y) /\+     (~F(y,f_z(x,y)) \/ ~F(f_z(x,y),f_z(x,y))) \/+     (F(x,y) /\ G(x,y)) /\ +     (~G(x,f_z(x,y)) \/ ~G(f_z(x,y),f_z(x,y)))>>]+-}+                                    (Set.map render ((Set.map list_conj (simpdnf (runSkolem (askolemize ((.~.) (generalize dpExampleFm)))))) :: Set.Set (Formula FOLEQ))))]+    where f = pApp "F"+          g = pApp "G"+          sk1 = fApp (toSkolem "z")+          x = vt "x"+          y = vt "y"+          z = vt "z"++{-+askolemize (simpdnf (generalize dpExampleFm)) ->+ <<forall x y. F(x,y) /\ (~F(y,f_z(x,y)) \/ ~F(f_z(x,y), f_z(x,y))) \/ (F(x,y) /\ G(x,y)) /\ (~G(x,f_z(x,y)) \/ ~G(f_z(x,y),f_z(x,y)))>>+-}
Data/Logic/Tests/Harrison/Prop.hs view
@@ -6,13 +6,15 @@  import Data.Logic.Classes.Combine (Combinable(..), (∨), (∧)) import Data.Logic.Classes.Constants (true, false)+import Data.Logic.Classes.Formula (atomic) 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)+                                 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.Map as Map import qualified Data.Set as Set import Prelude hiding (negate) import Test.HUnit (Test(TestCase, TestList, TestLabel), assertEqual)@@ -51,11 +53,14 @@ 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"})))))))+          expected = (Iff+                      (Imp+                       (Atom (P {pname = "p"}))+                       (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@@ -74,7 +79,7 @@  test04 :: Test test04 = TestCase $ assertEqual "fixity tests" expected input-    where (input, expected) = unzip (map (\ (fm, flag) -> (eval fm (const False), flag)) pairs)+    where (input, expected) = unzip (map (\ (fm, flag) -> (eval fm Map.empty, flag)) pairs)           pairs :: [(Formula String, Bool)]           pairs =               [ ( true .&. false .=>. false .&. true,  True)@@ -102,14 +107,15 @@ 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 "p", P "q", P "r"],+               [([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],False),+               ([True,True,True],True)])           (p, q, r) = (Atom (P "p"), Atom (P "q"), Atom (P "r"))  -- ------------------------------------------------------------------------- @@ -120,18 +126,20 @@ 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)]+                ([P "p", P "q"],+                 [([False,False],True),+                  ([False,True],True),+                  ([True,False],True),+                  ([True,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)]+              expected = ([P "p"],+                          [([False],False),+                          ([True],False)])               p = Atom (P "p")  -- ------------------------------------------------------------------------- @@ -291,16 +299,17 @@  test29 :: Test test29 = TestCase $ assertEqual "dnf 1 (p. 56)" expected input-    where input = (dnf fm, truthTable fm)+    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)])+                      ([P {pname = "p"}, P {pname = "q"}, P {pname = "r"}],+                       [([False,False,False],False),+                        ([False,False,True],False),+                        ([False,True,False],False),+                        ([False,True,True],True),+                        ([True,False,False],True),+                        ([True,False,True],False),+                        ([True,True,False],True),+                        ([True,True,True],False)]))           fm = (p .|. q .&. r) .&. (((.~.)p) .|. ((.~.)r))           p = Atom (P "p")           q = Atom (P "q")@@ -308,7 +317,7 @@  test30 :: Test test30 = TestCase $ assertEqual "dnf 2 (p. 56)" expected input-    where input = dnf (p .&. q .&. r .&. s .&. t .&. u .|. u .&. v :: Formula Prop)+    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")@@ -366,7 +375,7 @@  test34 :: Test test34 = TestCase $ assertEqual "dnf" expected input-    where input = (dnf fm, tautology (Iff fm (dnf fm)))+    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")@@ -379,7 +388,7 @@  test35 :: Test test35 = TestCase $ assertEqual "cnf" expected input-    where input = (cnf fm, tautology (Iff fm (cnf fm)))+    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
Data/Logic/Tests/Harrison/Resolution.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings, RankNTypes, ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Data.Logic.Tests.Harrison.Resolution where @@ -9,20 +9,20 @@ 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.Resolution (resolution1, resolution2, resolution3, 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.FOL (Function(Skolem), TermType) 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+import Data.Logic.Tests.HUnit  tests :: Test (Formula FOLEQ)-tests = TestLabel "Data.Logic.Tests.Harrison.Resolution" $ TestList [test01, test02, test03, test04]+tests = TestLabel "Data.Logic.Tests.Harrison.Resolution" $+        TestList [test01, test02, test03, test04, test05]  -- -------------------------------------------------------------------------  -- Barber's paradox is an example of why we need factoring.                  @@ -30,7 +30,7 @@  test01 :: Test (Formula FOLEQ) test01 = TestCase $ assertEqual "Barber's paradox (p. 181)" expected input-    where input = simpcnf (runSkolem (skolemize ((.~.)barb)))+    where input = simpcnf (runSkolem (skolemize id ((.~.)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@@ -38,7 +38,7 @@                                    Set.fromList [shaves [fx [b],fx [b]], (.~.)(shaves [b,     fx [b]])]]           x = vt (fromString "x")           b = vt (fromString "b")-          fx = fApp (Skolem 1)+          fx = fApp (Skolem "x")           shaves = pApp (fromString "shaves")   -- ------------------------------------------------------------------------- @@ -47,19 +47,19 @@  test02 :: Test (Formula FOLEQ) test02 = TestCase $ assertEqual "Davis-Putnam example" expected input-    where input = runSkolem (resolution1 unifyAtomsEq (dpExampleFm :: Formula FOLEQ))+    where input = runSkolem (resolution1 (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]))+dpExampleFm = exists "x" . exists "y" .for_all "z" $+              (f [x, y] .=>. (f [y, z] .&. f [z, z])) .&.+              ((f [x, y] .&. g [x, y]) .=>. (g [x, z] .&. g [z, z]))     where-      x = fromString "x"-      y = fromString "y"-      z = fromString "z"-      g = pApp (fromString "G")-      f = pApp (fromString "F")+      x = vt "x" :: TermType+      y = vt "y"+      z = vt "z"+      g = pApp "G" :: [TermType] -> Formula FOLEQ+      f = pApp "F"  -- -------------------------------------------------------------------------  -- This is now a lot quicker.                                                @@ -92,3 +92,40 @@       z = fromString "z"       p = pApp (fromString "P")       q = pApp (fromString "Q")++test05 :: Test (Formula FOLEQ)+test05 = TestCase $ assertEqual "Socrates syllogism" expected input+    where input = (runSkolem (resolution1 socrates),+                   runSkolem (resolution2 socrates),+                   runSkolem (resolution3 socrates),+                   runSkolem (presolution socrates),+                   runSkolem (resolution1 notSocrates),+                   runSkolem (resolution2 notSocrates),+                   runSkolem (resolution3 notSocrates),+                   runSkolem (presolution notSocrates))+          expected = (Set.singleton (Success True),+                      Set.singleton (Success True),+                      Set.singleton (Success True),+                      Set.singleton (Success True),+                      Set.singleton (Success {-False-} True),+                      Set.singleton (Success {-False-} True),+                      Set.singleton (Failure ["No proof found"]),+                      Set.singleton (Success {-False-} True))++socrates :: Formula FOLEQ+socrates =+    (for_all x (s [vt x] .=>. h [vt x]) .&. for_all x (h [vt x] .=>. m [vt x])) .=>. for_all x (s [vt x] .=>. m [vt x])+    where+      x = fromString "x"+      s = pApp (fromString "S")+      h = pApp (fromString "H")+      m = pApp (fromString "M")++notSocrates :: Formula FOLEQ+notSocrates =+    (for_all x (s [vt x] .=>. h [vt x]) .&. for_all x (h [vt x] .=>. m [vt x])) .=>. for_all x (s [vt x] .=>.  ((.~.)(m [vt x])))+    where+      x = fromString "x"+      s = pApp (fromString "S")+      h = pApp (fromString "H")+      m = pApp (fromString "M")
Data/Logic/Tests/Harrison/Skolem.hs view
@@ -12,7 +12,7 @@ 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.Tests.HUnit () import Data.Logic.Types.Harrison.Equal (FOLEQ, PredName(..)) import Data.Logic.Types.Harrison.FOL (Function(..)) import Data.Logic.Types.Harrison.Formulas.FirstOrder (Formula)@@ -75,23 +75,23 @@  test04 :: Test test04 = TestCase $ assertEqual "skolemize 1 (p. 150)" expected input-    where input = runSkolem $ skolemize fm+    where input = runSkolem (skolemize id fm) :: Formula FOLEQ           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"]]])+          expected = ((.~.)(pApp (Named "<") [vt "x",fApp (Skolem "y") [vt "x"]])) .|.+                     (pApp (Named "<") [fApp "*" [vt "x",vt "u"],fApp "*" [fApp (Skolem "y") [vt "x"],fApp (Skolem "v") [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+          input = runSkolem (skolemize id fm) :: Formula FOLEQ           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 q [fApp (Skolem "y") []]) .|.                       (((.~.)(pApp p [vt "z"])) .|.                        ((.~.)(pApp q [vt "z"]))))
Data/Logic/Tests/Harrison/Unif.hs view
@@ -7,8 +7,8 @@ import Control.Applicative.Error (Failing(..), failing) import Data.Logic.Classes.Term (Term(fApp, vt), tsubst) import Data.Logic.Harrison.Unif (fullUnify)+import Data.Logic.Tests.HUnit () import Data.Logic.Types.Harrison.FOL (TermType)-import Data.Logic.Tests.Harrison.HUnit () import Test.HUnit (Test(TestCase, TestList, TestLabel), assertEqual)  tests :: Test
Data/Logic/Tests/Logic.hs view
@@ -3,36 +3,37 @@ {-# 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.Combine (Combinable(..), Combination(..), BinOp(..), (⇒))+import Data.Logic.Classes.Constants (Constants(..), true) 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.FirstOrder (FirstOrderFormula(..), showFirstOrder, (∀))+import Data.Logic.Classes.Atom (Atom) import Data.Logic.Classes.Literal (Literal) import Data.Logic.Classes.Negate (negated, (.~.))+import Data.Logic.Classes.Pretty (pretty)+import Data.Logic.Classes.Propositional (PropositionalFormula) 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.Harrison.FOL (fv, subst, list_conj, list_disj)+import Data.Logic.Harrison.Normal (trivial)+import Data.Logic.Harrison.Prop (TruthTable, truthTable)+import Data.Logic.Harrison.Skolem (runSkolem, skolemize, pnf) 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 Data.Logic.Tests.Common (TFormula, TAtom, TTerm, myTest)+import Data.Logic.Types.FirstOrder import qualified Data.Map as Map-import qualified Data.Set as Set+import qualified Data.Set.Extra as Set+import Data.Set.Extra (fromList) import Data.String (IsString(fromString))-import PropLogic (PropForm(..), TruthTable, truthTable)+-- 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)+tests = TestLabel "Test.Logic" $ TestList [precTests, normalTests, theoremTests]  {- formCase :: (FirstOrderFormula TFormula TAtom V, AtomEq TAtom Pr TTerm, Term TTerm V AtomicFunction) =>@@ -40,8 +41,9 @@ formCase s expected input = TestLabel s $ TestCase (assertEqual s expected input) -} -precTests :: [Test]+precTests :: Test precTests =+    TestList     [ myTest "Logic - prec test 1"                ((a .&. b) .|. c)                (a .&. b .|. c)@@ -58,9 +60,42 @@     , myTest "Logic - prec test 3"                ((a .&. b) .&. c) -- infixl, with infixr we get (a .&. (b .&. c))                (a .&. b .&. c :: TFormula)+    , let x = vt "x" :: TTerm+          y = vt "y" :: TTerm+          -- This is not the desired result, but it is the result we+          -- will get due to the fact that function application+          -- precedence is always 10, and that rule applies when you+          -- put the operator in parentheses.  This means that direct+          -- input of examples from Harrison won't always work.+          expected = ((∀) "y" (pApp "g" [y])) ⇒ (pApp "f" [y]) :: TFormula+          input =     (∀) "y" (pApp "g" [y])  ⇒ (pApp "f" [y]) :: TFormula in+      myTest "Logic - prec test 4" expected input     , TestCase (assertEqual "Logic - Find a free variable"                 (fv (for_all "x" (x .=. y) :: TFormula))                 (Set.singleton "y"))+{-+    , let a = Combine (BinOp+                       (Combine (BinOp+                                 T+                                 (:=>:)+                                 (Combine (BinOp T (:&:) T))))+                       (:&:)+                       (Combine (BinOp+                                 (Combine (BinOp T (:&:) T))+                                 (:=>:)+                                 (Combine (BinOp T (:&:) T)))))+          b = Combine (BinOp+                       (Combine (BinOp+                                 T+                                 (:=>:)+                                 (Combine (BinOp+                                           (Combine (BinOp T (:&:) T))+                                           (:&:)+                                           (Combine (BinOp T (:&:) T))))))+                       (:=>:)+                       (Combine (BinOp T (:&:) T))) in+      ()+-}     , TestCase (assertEqual "Logic - Substitute a variable"                 (map sub                          [ for_all "x" (x .=. y) {- :: Formula String String -}@@ -81,6 +116,25 @@ z :: TTerm z = vt (fromString "z") +normalTests =+    let s = pApp "S"+        h = pApp "H"+        m = pApp "M"+        x2 = vt "x2" :: TTerm+        for_all' x fm = for_all (fromString x) fm+        exists' x fm = exists (fromString x) fm+    in+    TestList+    [TestCase (assertEqual+               "nnf"+               (show (pretty (for_all' "x" (exists' "x2" ((s[x2] .&. ((.~.)(h[x2])) .|. h[x2] .&. ((.~.)(m[x2]))) .|. ((.~.)(s[x])) .|. m[x])) :: TFormula)))+               -- <<forall x. exists x'. (S(x') /\ ~H(x') \/ H(x') /\ ~M(x')) \/ ~S(x) \/ M(x)>>+               -- ∀x. ∃x2. ((S(x2) ∧ ¬H(x2) ∨ H(x2) ∧ ¬M(x2)) ∨ ¬S(x) ∨ M(x))+               (show+                (pretty+                 (pnf (((for_all' "x" (s[x] .=>. h[x])) .&. (for_all "x" (h[x] .=>. m[x]))) .=>.+                    (for_all "x" (s[x] .=>. m[x])) :: TFormula) :: TFormula))))]+ -- |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@@ -159,139 +213,164 @@       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 :: 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)+        m = pApp "M"+        socrates1 = (for_all "x"   (s [x] .=>. h [x]) .&. for_all "x" (h [x] .=>. m [x]))  .=>.  for_all "x" (s [x] .=>. m [x])  :: TFormula -- First two clauses grouped - compare to 5+        socrates2 =  for_all "x" (((s [x] .=>. h [x]) .&.             (h [x] .=>. m [x]))  .=>.              (s [x] .=>. m [x])) :: TFormula -- shared binding for x+        socrates3 = (for_all "x"  ((s [x] .=>. h [x]) .&.             (h [x] .=>. m [x]))) .=>. (for_all "y" (s [y] .=>. m [y])) :: TFormula -- First two clauses share x, third is renamed y+        socrates5 =  for_all "x"   (s [x] .=>. h [x]) .&. for_all "x" (h [x] .=>. m [x])   .=>.  for_all "x" (s [x] .=>. m [x])  :: TFormula -- like 1, but less parens - check precedence +        socrates6 =  for_all "x"   (s [x] .=>. h [x]) .&. for_all "y" (h [y] .=>. m [y])   .=>.  for_all "z" (s [z] .=>. m [z])  :: TFormula -- Like 5, but with variables renamed+        socrates7 =  for_all "x"  ((s [x] .=>. h [x]) .&.             (h [x] .=>. m [x])   .&.               (m [x] .=>. ((.~.) (s [x])))) .&. (s [fApp "socrates" []]) in +    TestList+    [ myTest "Logic - theorem test 1"+                (True,(Set.empty, ([]{-Just (CJ [])-},[([],True)])))+                (runNormal (theorem socrates2), table socrates2)     , 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))+                 (fromList [fromList [Predicate (Apply "H" [FunApp (toSkolem "x") []]),+                                      Predicate (Apply "M" [Var "y"]),+                                      Predicate (Apply "S" [FunApp (toSkolem "x") []]),+                                      Combine ((:~:) (Predicate (Apply "S" [Var "y"])))],+                            fromList [Predicate (Apply "M" [Var "y"]),+                                      Predicate (Apply "S" [FunApp (toSkolem "x") []]),+                                      Combine ((:~:) (Predicate (Apply "M" [FunApp (toSkolem "x") []]))),+                                      Combine ((:~:) (Predicate (Apply "S" [Var "y"])))],+                            fromList [Predicate (Apply "M" [Var "y"]),+                                      Combine ((:~:) (Predicate (Apply "H" [FunApp (toSkolem "x") []]))),+                                      Combine ((:~:) (Predicate (Apply "M" [FunApp (toSkolem "x") []]))),+                                      Combine ((:~:) (Predicate (Apply "S" [Var "y"])))]],+                 ([(Apply "H" [fApp (toSkolem "x") []]),+                   (Apply "M" [vt ("y")]),+                   (Apply "M" [fApp (toSkolem "x") []]),+                   (Apply "S" [vt ("y")]),+                   (Apply "S" [fApp (toSkolem "x") []])],+                  [([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)])))                 -    , 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])))+                (runNormal (theorem socrates3),+                 runNormal (inconsistant socrates3),+                 table socrates3)+    , myTest "socrates1 truth table"+             (let skx = fApp (toSkolem "x") in+              (fromList [fromList [Predicate (Apply "H" [FunApp (toSkolem "x") []]),+                                   Predicate (Apply "M" [Var "x"]),+                                   Predicate (Apply "S" [FunApp (toSkolem "x") []]),+                                   Combine ((:~:) (Predicate (Apply "S" [Var "x"])))],+                         fromList [Predicate (Apply "M" [Var "x"]),+                                   Predicate (Apply "S" [FunApp (toSkolem "x") []]),+                                   Combine ((:~:) (Predicate (Apply "M" [FunApp (toSkolem "x") []]))),+                                   Combine ((:~:) (Predicate (Apply "S" [Var "x"])))],+                         fromList [Predicate (Apply "M" [Var "x"]),+                                   Combine ((:~:) (Predicate (Apply "H" [FunApp (toSkolem "x") []]))),+                                   Combine ((:~:) (Predicate (Apply "M" [FunApp (toSkolem "x") []]))),+                                   Combine ((:~:) (Predicate (Apply "S" [Var "x"])))]],+              ([(Apply "H" [skx []]),+                (Apply "M" [x]),+                (Apply "M" [skx []]),+                (Apply "S" [x]),+                (Apply "S" [skx []])],+               -- Clauses are always true if x is not socrates+               -- Nothing,+               {- (Just (CJ [DJ [A (h[skx[]]), A (m[x]),     A (s[skx[]]), N (s[x])],  -- false when x is socrates and not mortal, and skx is socrates and human+                          DJ [A (m[x]),     A (s[skx[]]), N (A (m[skx[]])), N (s[x])],+                          DJ [A (m[x]),     N (A (h[x])), N (A (m[skx[]])), N (s[x])]])) -}+            --    h[skx] m[x] m[skx] s[x] s[skx]+               [([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)])))+                (table socrates1) +    , let skx = fApp (toSkolem "x")+          {- sky = fApp (toSkolem "y") -} in+      myTest "Socrates formula skolemized"+              -- ((s[skx []] .&. (.~.)(h[skx []]) .|. h[sky[]] .&. (.~.)(m[sky []])) .|. (.~.)(s[z]) .|. m[z])+                 ((s[skx []] .&. (.~.)(h[skx []]) .|. h[skx[]] .&. (.~.)(m[skx []])) .|. (.~.)(s[x]) .|. m[x])+                 (runSkolem (skolemize id socrates5) :: TFormula)++    , let skx = fApp (toSkolem "x")+          sky = fApp (toSkolem "y") in+      myTest "Socrates formula skolemized"+              -- ((s[skx []] .&. (.~.)(h[skx []]) .|. h[sky[]] .&. (.~.)(m[sky []])) .|. (.~.)(s[z]) .|. m[z])+                 ((s[skx []] .&. (.~.)(h[skx []]) .|. h[sky[]] .&. (.~.)(m[sky []])) .|. (.~.)(s[z]) .|. m[z])+                 (runSkolem (skolemize id socrates6) :: TFormula)+     , 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")]))]]),+                 (fromList [fromList [Predicate (Apply "H" [Var "x"]),+                                      Combine ((:~:) (Predicate (Apply "S" [Var "x"])))],+                            fromList [Predicate (Apply "M" [Var "x"]),+                                      Combine ((:~:) (Predicate (Apply "H" [Var "x"])))],+                            fromList [Predicate (Apply "S" [FunApp "socrates" []])],+                            fromList [Combine ((:~:) (Predicate (Apply "M" [Var "x"]))),+                                      Combine ((:~:) (Predicate (Apply "S" [Var "x"])))]],+                 ([(Apply ("H") [vt ("x")]),+                   (Apply ("M") [vt ("x")]),+                   (Apply ("S") [vt ("x")]),+                   (Apply ("S") [fApp ("socrates") []])],                   [([False,False,False,False],False),                    ([False,False,False,True],True),                    ([False,False,True,False],False),@@ -307,7 +386,7 @@                    ([True,True,False,False],False),                    ([True,True,False,True],True),                    ([True,True,True,False],False),-                   ([True,True,True,True],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") []])],@@ -325,23 +404,22 @@                 -- 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)))+                (runNormal (theorem socrates7), runNormal (inconsistant socrates7), table socrates7, runNormal (clauseNormalForm socrates7) :: 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"))))]]),+          expected = (fromList [fromList [Predicate (Apply "L" [FunApp (toSkolem "x") []]),+                                          Combine ((:~:) (Predicate (Apply "F" [Var "x2"]))),+                                          Combine ((:~:) (Predicate (Apply "L" [Var "x"])))],+                                fromList [Combine ((:~:) (Predicate (Apply "F" [Var "x2"]))),+                                          Combine ((:~:) (Predicate (Apply "F" [FunApp (toSkolem "x") []]))),+                                          Combine ((:~:) (Predicate (Apply "L" [Var "x"])))]],+                      ([(Apply ("F") [vt ("x2")]),+                       (Apply ("F") [fApp (toSkolem "x") []]),+                       (Apply ("L") [vt ("x")]),+                       (Apply ("L") [fApp (toSkolem "x") []])],                       [([False,False,False,False],True),                        ([False,False,False,True],True),                        ([False,False,True,False],True),@@ -357,15 +435,24 @@                        ([True,True,False,False],True),                        ([True,True,False,True],True),                        ([True,True,True,False],False),-                       ([True,True,True,True],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)])+          expected = (fromList [fromList [Predicate (Apply "L" [FunApp (toSkolem "x") []]),+                                          Combine ((:~:) (Predicate (Apply "F" [Var "z"]))),+                                          Combine ((:~:) (Predicate (Apply "L" [Var "y"])))],+                                fromList [Combine ((:~:) (Predicate (Apply "F" [Var "z"]))),+                                          Combine ((:~:) (Predicate (Apply "F" [FunApp (toSkolem "x") []]))),+                                          Combine ((:~:) (Predicate (Apply "L" [Var "y"])))]],+                      ([(Apply ("F") [vt ("z")]),+                       (Apply ("F") [fApp (toSkolem "x") []]),+                       (Apply ("L") [vt ("y")]),+                       (Apply ("L") [fApp (toSkolem "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 renamed" expected input     ] @@ -423,19 +510,37 @@  convertA = Just . A -}+         {- forall formula atom term v p f.+         (FirstOrderFormula formula atom v,+          PropositionalFormula formula atom,+          Atom atom term v,+          AtomEq atom p term,+          Constants p, Eq p, Term term v f, Literal formula atom v,+          Ord formula, Skolem f v, IsString v, Variable v, TD.Display formula) => -} -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 :: forall formula atom term v f.+         (FirstOrderFormula formula atom v,+          PropositionalFormula formula atom,+          Literal formula atom,+          Atom atom term v,+          Term term v f,+          Ord formula, Ord atom) =>+         formula -> (Set.Set (Set.Set formula), TruthTable atom) table f =     -- truthTable :: Ord a => PropForm a -> TruthTable a-    tt cnf'+    (cnf, truthTable 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))+      cnf' :: formula+      cnf' = list_conj (Set.map list_disj cnf :: Set.Set formula) -- CJ (map (DJ . map n) cnf)+      cnf :: Set.Set (Set.Set formula)+      cnf = runNormal (clauseNormalForm f)       fromSS = map Set.toList . Set.toList-      n f = (if negated f then N . A . (.~.) else A) $ f+      -- n f = (if negated f then (.~.) . atomic . (.~.) else atomic) $ f+      -- list_disj = setFoldr1 (.|.)+      -- list_conj = setFoldr1 (.&.)++setFoldr1 :: (a -> a -> a) -> Set.Set a -> a+setFoldr1 f s =+    case Set.minView s of+      Nothing -> error "setFoldr1"+      Just (x, s') -> Set.fold f x s'
Data/Logic/Tests/Main.hs view
@@ -1,6 +1,8 @@ import Data.Logic.Tests.Common (TestFormula, TestProof, V, TFormula, TAtom, TTerm) import System.Exit import Test.HUnit+import qualified Data.Logic.Harrison.DP as DP+import qualified Data.Logic.Harrison.PropExamples as PropExamples import qualified Data.Logic.Tests.Harrison.Main as Harrison import qualified Data.Logic.Tests.Logic as Logic import qualified Data.Logic.Tests.Chiou0 as Chiou0@@ -13,7 +15,9 @@                          Chiou0.tests,                          -- TPTP.tests,  -- This has a problem in the rendering code - it loops                          Data.tests formulas proofs,-                         Harrison.tests]) >>=+                         Harrison.tests,+                         PropExamples.tests,+                         DP.tests]) >>=     doCounts     where       doCounts counts' = exitWith (if errors counts' /= 0 || failures counts' /= 0 then ExitFailure 1 else ExitSuccess)
+ Data/Logic/Types/Common.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+module Data.Logic.Types.Common where++import Data.Logic.Classes.Variable (Variable(..))+import qualified Data.Set as Set+import Text.PrettyPrint (text)++instance Variable String where+    variant x vars = if Set.member x vars then variant (x ++ "'") vars else x+    prefix p x = p ++ x+    prettyVariable = text++{-+instance Variable String where+    variant v vs =+        if Set.member v vs then variant (next v) (Set.insert v vs) else v+        where+          next :: String -> String+          next s =+              case break (not . isDigit) (reverse s) of+                (_, "") -> "x"+                ("", nondigits) -> nondigits ++ "2"+                (digits, nondigits) -> nondigits ++ show (1 + read (reverse digits) :: Int)+-}
Data/Logic/Types/FirstOrder.hs view
@@ -11,16 +11,17 @@     ) where  import Data.Data (Data)-import Data.Logic.Classes.Arity (Arity)+import qualified Data.Logic.Classes.Apply as C+import qualified Data.Logic.Classes.Atom as C import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..)) import Data.Logic.Classes.Constants (Constants(..), asBool)-import Data.Logic.Classes.Equals (AtomEq(..), (.=.), pApp, substAtomEq, varAtomEq)-import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), Quant(..))+import Data.Logic.Classes.Equals (AtomEq(..), (.=.), pApp, substAtomEq, varAtomEq, prettyAtomEq)+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), Quant(..), prettyFirstOrder, fixityFirstOrder, foldAtomsFirstOrder, mapAtomsFirstOrder) import qualified Data.Logic.Classes.Formula as C import Data.Logic.Classes.Literal (Literal(..)) import Data.Logic.Classes.Negate (Negatable(..))-import Data.Logic.Classes.Skolem (Skolem(..))-import Data.Logic.Classes.Term (Term(..))+import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), botFixity)+import Data.Logic.Classes.Term (Term(..), Function) import Data.Logic.Classes.Variable (Variable(..)) import Data.Logic.Classes.Propositional (PropositionalFormula(..)) import Data.Logic.Harrison.Resolution (matchAtomsEq)@@ -37,7 +38,7 @@     | 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,Data,Typeable,Show)+    deriving (Eq, Ord, Data, Typeable, Show, Read)  -- |A temporary type used in the fold method to represent the -- combination of a predicate and its arguments.  This reduces the@@ -46,7 +47,7 @@ data Predicate p term     = Equal term term     | Apply p [term]-    deriving (Eq,Ord,Data,Typeable,Show,Read)+    deriving (Eq, Ord, Data, Typeable, Show, Read)  -- | The range of a term is an element of a set. data PTerm v f@@ -56,7 +57,7 @@                                     -- Constants are encoded as                                     -- nullary functions.  The result                                     -- is another term.-    deriving (Eq,Ord,Data,Typeable,Show,Read)+    deriving (Eq, Ord, Data, Typeable, Show, Read)  instance Negatable (Formula v p f) where     negatePrivate x = Combine ((:~:) x)@@ -65,24 +66,27 @@  instance Constants p => Constants (Formula v p f) where     fromBool = Predicate . fromBool+    asBool (Predicate x) = asBool x+    asBool _ = Nothing  instance Constants p => Constants (Predicate p (PTerm v f)) where     fromBool x = Apply (fromBool x) []+    asBool (Apply p _) = asBool p+    asBool _ = Nothing -instance (Constants (Formula v p f), Ord v, Ord p, Ord f) => Combinable (Formula v p f) where+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, 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 (Apply p ts)) = pApp p ts-    atomic _ = error "atomic method of PropositionalFormula for Parameterized: invalid argument"+instance (C.Predicate p, Function f v) => C.Formula (Formula v p f) (Predicate p (PTerm v f)) where+    atomic = Predicate+    foldAtoms = foldAtomsFirstOrder+    mapAtoms = mapAtomsFirstOrder++instance (C.Formula (Formula v p f) (Predicate p (PTerm v f)), Variable v, C.Predicate p, Function f v, Constants (Formula v p f), Combinable (Formula v p f)+         ) => PropositionalFormula (Formula v p f) (Predicate p (PTerm v f)) where     foldPropositional co tf at formula =         maybe testFm tf (asBool formula)         where@@ -90,9 +94,9 @@               case formula of                 Quant _ _ _ -> error "foldF0: quantifiers should not be present"                 Combine x -> co x-                Predicate x -> at (Predicate x)+                Predicate x -> at x -instance (Variable v, Data v, Skolem f, Data f, Ord f) => Term (PTerm v f) v f where+instance (Variable v, Function f v) => Term (PTerm v f) v f where     foldTerm vf fn t =         case t of           Var v -> vf v@@ -116,18 +120,17 @@     apply' = Apply -} -instance (Constants p, Eq p, Arity p, Show p) => AtomEq (Predicate p (PTerm v f)) p (PTerm v f) where+instance C.Predicate p => AtomEq (Predicate p (PTerm v f)) p (PTerm v f) where     foldAtomEq ap tf _ (Apply p ts) = maybe (ap p ts) tf (asBool p)     foldAtomEq _ _ eq (Equal t1 t2) = eq t1 t2     equals = Equal     applyEq' = Apply -instance (AtomEq (Predicate p (PTerm v f)) p (PTerm v f),+instance (C.Formula (Formula v p f) (Predicate p (PTerm v f)),+          AtomEq (Predicate p (PTerm v f)) p (PTerm v f),           Constants (Formula v p f),-          Variable v, Ord v, Data v, Show v,-          Ord p, Data p, Show p, Constants p,-          Skolem f, Ord f, Data f, Show f) =>-         FirstOrderFormula (Formula v p f) (Predicate p (PTerm v f)) v where+          Variable v, C.Predicate p, Function f v+         ) => FirstOrderFormula (Formula v p f) (Predicate p (PTerm v f)) v where     for_all v x = Quant Forall v x     exists v x = Quant Exists v x     foldFirstOrder qu co tf at f =@@ -143,10 +146,7 @@           (Combine x, Combine y) -> co x y           (Predicate x, Predicate y) -> at x y           _ -> Nothing--}-    atomic = Predicate -{- instance (Constants (Formula v p f),           Variable v, Ord v, Data v, Show v,           Arity p, Constants p, Ord p, Data p, Show p,@@ -159,8 +159,8 @@     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+instance (Constants p, Ord v, Ord p, Ord f, Constants (Predicate p (PTerm v f)), C.Formula (Formula v p f) (Predicate p (PTerm v f))+         ) => Literal (Formula v p f) (Predicate p (PTerm v f)) where     foldLiteral neg tf at f =         case f of           Quant _ _ _ -> error "Invalid literal"@@ -172,7 +172,7 @@                               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+instance (C.Predicate p, Variable v, Function f v) => C.Atom (Predicate p (PTerm v f)) (PTerm v f) v where     substitute = substAtomEq     freeVariables = varAtomEq     allVariables = varAtomEq@@ -183,6 +183,21 @@     isRename = isRenameOfAtomEq     getSubst = getSubstAtomEq +instance (Variable v, Pretty v,+          C.Predicate p, Pretty p,+          Function f v, Pretty f) => Pretty (Predicate p (PTerm v f)) where+    pretty atom = prettyAtomEq pretty pretty pretty 0 atom++instance (C.Formula (Formula v p f) (Predicate p (PTerm v f)),+          C.Predicate p, Variable v, Function f v, HasFixity (Predicate p (PTerm v f))) => HasFixity (Formula v p f) where+    fixity = fixityFirstOrder++instance (C.Formula (Formula v p f) (Predicate p (PTerm v f)), Variable v, C.Predicate p, Function f v) => Pretty (Formula v p f) where+    pretty f = prettyFirstOrder (\ _ -> pretty) pretty 0 $ f++instance HasFixity (Predicate p term) where+    fixity = const botFixity+ $(deriveSafeCopy 1 'base ''PTerm) $(deriveSafeCopy 1 'base ''Formula) $(deriveSafeCopy 2 'extension ''Predicate)@@ -196,7 +211,7 @@     | NotEqual_v1 term term     | Constant_v1 Bool     | Apply_v1 p [term]-    deriving (Eq,Ord,Data,Typeable,Show,Read)+    deriving (Eq, Ord, Data, Typeable, Show, Read)  $(deriveSafeCopy 1 'base ''Predicate_v1)
Data/Logic/Types/FirstOrderPublic.hs view
@@ -12,13 +12,15 @@     ) where  import Data.Data (Data)-import Data.Logic.Classes.Arity (Arity)+import Data.Logic.Classes.Apply (Predicate) import Data.Logic.Classes.Combine (Combinable(..), Combination(..)) import Data.Logic.Classes.Constants (Constants(..))-import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..))+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), prettyFirstOrder, foldAtomsFirstOrder, mapAtomsFirstOrder, fixityFirstOrder)+import qualified Data.Logic.Classes.Formula as C import Data.Logic.Classes.Negate (Negatable(..))-import Data.Logic.Classes.Skolem (Skolem(..))-import Data.Logic.Classes.Term (Term(..))+import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(fixity))+import Data.Logic.Classes.Propositional (PropositionalFormula(..))+import Data.Logic.Classes.Term (Function) import Data.Logic.Classes.Variable (Variable) import Data.Logic.Normal.Implicative (implicativeNormalForm, ImplicativeForm, runNormal) import qualified Data.Logic.Types.FirstOrder as N@@ -35,7 +37,7 @@ -- |The new Formula type is just a wrapper around the Native instance -- (which eventually should be renamed the Internal instance.)  No -- derived Eq or Ord instances.-data Formula v p f = Formula {unFormula :: N.Formula v p f} deriving (Data, Typeable)+data Formula v p f = Formula {unFormula :: N.Formula v p f} deriving (Data, Typeable, Show)  instance Bijection (Formula v p f) (N.Formula v p f) where     public = Formula@@ -51,63 +53,66 @@     negatePrivate = Formula . negatePrivate . unFormula     foldNegation normal inverted = foldNegation (normal . Formula) (inverted . Formula) . unFormula -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+instance (Constants (N.Formula v p f), Predicate p, Variable v, Function f v) => Constants (Formula v p f) where     fromBool = Formula . fromBool+    asBool = asBool . unFormula -instance (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+instance (C.Formula (N.Formula v p f) (N.Predicate p (N.PTerm v f)),+          Constants (Formula v p f),+          Constants (N.Formula v p f),+          Variable v, Predicate p, Function f v) => Combinable (Formula v p f) where     x .<=>. y = Formula $ (unFormula x) .<=>. (unFormula y)     x .=>.  y = Formula $ (unFormula x) .=>. (unFormula y)     x .|.   y = Formula $ (unFormula x) .|. (unFormula y)     x .&.   y = Formula $ (unFormula x) .&. (unFormula y) -instance (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 (Predicate p, Function f v) => C.Formula (Formula v p f) (N.Predicate p (N.PTerm v f)) where+    atomic = Formula . C.atomic+    foldAtoms = foldAtomsFirstOrder+    mapAtoms = mapAtomsFirstOrder -instance (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, 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+instance (C.Formula (Formula v p f) (N.Predicate p (N.PTerm v f)),+          C.Formula (N.Formula v p f) (N.Predicate p (N.PTerm v f)),+          Variable v, Predicate p, Function f v) => FirstOrderFormula (Formula v p f) (N.Predicate p (N.PTerm v f)) v where     for_all v x = public $ for_all v (intern x :: N.Formula v p f)     exists v x = public $ exists v (intern x :: N.Formula v p f)     foldFirstOrder qu co tf at f = foldFirstOrder qu' co' tf at (intern f :: N.Formula v p f)         where qu' quant v form = qu quant v (public form)               co' x = co (public x)-{--    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 +instance (C.Formula (Formula v p f) (N.Predicate p (N.PTerm v f)),+          C.Formula (N.Formula v p f) (N.Predicate p (N.PTerm v f)),+          Show v, Show p, Show f, HasFixity (Formula v p f), Variable v, Predicate p,+          Function f v) => PropositionalFormula (Formula v p f) (N.Predicate p (N.PTerm v f)) where+    foldPropositional co tf at f = foldPropositional co' tf at (intern f :: N.Formula v p f)+        where co' x = co (public x)+ -- |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, Constants p, Skolem f, Variable v,-          Ord (N.Formula v p f)) => Ord (Formula v p f) where+instance (C.Formula (Formula v p f) (N.Predicate p (N.PTerm v f)),+          C.Formula (N.Formula v p f) (N.Predicate p (N.PTerm v f)),+          Predicate p, Function f v, Variable v) => Ord (Formula v p f) where     compare a b =-        let (a' :: Set (ImplicativeForm (N.Formula v p f))) = runNormal (implicativeNormalForm (intern a :: N.Formula v p f))-            (b' :: Set (ImplicativeForm (N.Formula v p f))) = runNormal (implicativeNormalForm (intern b :: N.Formula v p f)) in+        let (a' :: Set (ImplicativeForm (N.Formula v p f))) = runNormal (implicativeNormalForm (unFormula a))+            (b' :: Set (ImplicativeForm (N.Formula v p f))) = runNormal (implicativeNormalForm (unFormula b)) in         case compare a' b' of           EQ -> EQ           x -> {- if isRenameOf a' b' then EQ else -} x -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)),+instance (C.Formula (Formula v p f) (N.Predicate p (N.PTerm v f)),+          C.Formula (N.Formula v p f) (N.Predicate p (N.PTerm v f)),+          Predicate p, Function f v, Variable v, Constants (N.Predicate p (N.PTerm v f)),           FirstOrderFormula (Formula v p f) (N.Predicate p (N.PTerm v f)) v) => Eq (Formula v p f) where     a == b = compare a b == EQ++instance (Predicate p, Function f v) => HasFixity (Formula v p f) where+    fixity = fixityFirstOrder++instance (C.Formula (Formula v p f) (N.Predicate p (N.PTerm v f)),+          C.Formula (N.Formula v p f) (N.Predicate p (N.PTerm v f)),+          Pretty v, Show v, Variable v,+          Pretty p, Show p, Predicate p,+          Pretty f, Show f, Function f v) => Pretty (Formula v p f) where+    pretty formula = prettyFirstOrder (\ _prec a -> pretty a) pretty 0 formula  $(deriveSafeCopy 1 'base ''Formula)
Data/Logic/Types/Harrison/Equal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-} module Data.Logic.Types.Harrison.Equal where @@ -8,24 +8,29 @@ -- Copyright (co) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)   -- =========================================================================  +import Data.Generics (Data, Typeable)+import Data.List (intersperse)+import Data.Logic.Classes.Apply (Apply(..), Predicate) import Data.Logic.Classes.Arity (Arity(..))-import Data.Logic.Classes.Apply (Apply(..))+import qualified Data.Logic.Classes.Atom as C import Data.Logic.Classes.Combine (Combination(..), BinOp(..)) import Data.Logic.Classes.Constants (Constants(fromBool), asBool) import Data.Logic.Classes.Equals (AtomEq(..), showFirstOrderFormulaEq, substAtomEq, varAtomEq)-import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..))-import qualified Data.Logic.Classes.FirstOrder as C+import Data.Logic.Classes.FirstOrder (fixityFirstOrder, mapAtomsFirstOrder, foldAtomsFirstOrder) import qualified Data.Logic.Classes.Formula as C import Data.Logic.Classes.Literal (Literal(..))+import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), Fixity(..), FixityDirection(..))+import qualified Data.Logic.Classes.Propositional as P import Data.Logic.Harrison.Resolution (matchAtomsEq) import Data.Logic.Harrison.Tableaux (unifyAtomsEq) import Data.Logic.Resolution (isRenameOfAtomEq, getSubstAtomEq) import Data.Logic.Types.Harrison.FOL (TermType(..)) import Data.Logic.Types.Harrison.Formulas.FirstOrder (Formula(..)) import Data.String (IsString(..))+import Text.PrettyPrint (text, cat)  data FOLEQ = EQUALS TermType TermType | R String [TermType] deriving (Eq, Ord, Show)-data PredName = (:=:) | Named String deriving (Eq, Ord, Show)+data PredName = (:=:) | Named String deriving (Eq, Ord, Show, Data, Typeable)  instance Arity PredName where     arity (:=:) = Just 2@@ -34,6 +39,10 @@ instance Show (Formula FOLEQ) where     show = showFirstOrderFormulaEq +instance HasFixity FOLEQ where+    fixity (EQUALS _ _) = Fixity 5 InfixL+    fixity _ = Fixity 10 InfixN+ instance IsString PredName where     fromString "=" = (:=:)     fromString s = Named s@@ -41,10 +50,25 @@ instance Constants PredName where     fromBool True = Named "true"     fromBool False = Named "false"+    asBool x+        | x == fromBool True = Just True+        | x == fromBool False = Just False+        | True = Nothing  instance Constants FOLEQ where     fromBool x = R (fromBool x) []+    asBool (R p _)+        | fromBool True == p = Just True+        | fromBool False == p = Just False+        | True = Nothing+    asBool _ = Nothing +instance Predicate PredName++instance Pretty PredName where+    pretty (:=:) = text "="+    pretty (Named s) = text s+ -- | Using PredName for the predicate type is not quite appropriate -- here, but we need to implement this instance so we can use it as a -- superclass of AtomEq below.@@ -55,6 +79,7 @@     apply' (:=:) [t1, t2] = EQUALS t1 t2     apply' (:=:) _ = error "arity" +{- instance FirstOrderFormula (Formula FOLEQ) FOLEQ String where     exists = Exists     for_all = Forall@@ -71,9 +96,30 @@           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+instance C.Formula (Formula FOLEQ) FOLEQ => P.PropositionalFormula (Formula FOLEQ) FOLEQ where+    foldPropositional co tf at fm =+        case fm of+          F -> tf False+          T -> tf True+          Atom a -> at a+          Not fm' -> co ((:~:) fm')+          And fm1 fm2 -> co (BinOp fm1 (:&:) fm2)+          Or fm1 fm2 -> co (BinOp fm1 (:|:) fm2)+          Imp fm1 fm2 -> co (BinOp fm1 (:=>:) fm2)+          Iff fm1 fm2 -> co (BinOp fm1 (:<=>:) fm2)+          Forall _ _ -> error "quantifier in propositional formula"+          Exists _ _ -> error "quantifier in propositional formula"++instance Pretty FOLEQ where+    pretty (EQUALS a b) = cat [pretty a, pretty (:=:), pretty b]+    pretty (R s ts) = cat ([pretty s, pretty "("] ++ intersperse (text ", ") (map pretty ts) ++ [text ")"])++instance HasFixity (Formula FOLEQ) where+    fixity = fixityFirstOrder++instance C.Formula (Formula FOLEQ) FOLEQ => Literal (Formula FOLEQ) FOLEQ where     foldLiteral neg tf at lit =         case lit of           F -> tf False@@ -93,7 +139,7 @@     applyEq' (:=:) [t1, t2] = EQUALS t1 t2     applyEq' _ _ = error "arity" -instance C.Formula FOLEQ TermType String where+instance C.Atom FOLEQ TermType String where     substitute = substAtomEq     freeVariables = varAtomEq     allVariables = varAtomEq
Data/Logic/Types/Harrison/FOL.hs view
@@ -8,21 +8,22 @@     ) where  import Data.Generics (Data, Typeable)+import Data.List (intersperse) import Data.Logic.Classes.Arity-import Data.Logic.Classes.Apply (Apply(..), showApply)-import Data.Logic.Classes.Combine (Combination(..), BinOp(..))+import Data.Logic.Classes.Apply (Apply(..), Predicate)+--import Data.Logic.Classes.Combine (Combination(..), BinOp(..)) import Data.Logic.Classes.Constants (Constants(fromBool), asBool)-import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), showFirstOrder)+--import Data.Logic.Classes.FirstOrder (foldAtomsFirstOrder, mapAtomsFirstOrder)+--import qualified Data.Logic.Classes.Formula as C+import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), Fixity(..), FixityDirection(..)) import Data.Logic.Classes.Skolem (Skolem(..)) import Data.Logic.Classes.Term (Term(vt, foldTerm, fApp))-import 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 qualified Data.Logic.Classes.FirstOrder as C+--import Data.Logic.Types.Harrison.Formulas.FirstOrder (Formula(..))+import qualified Data.Logic.Types.Common ({- instance Variable String -}) import Prelude hiding (pred)-import Text.PrettyPrint (text)+import Text.PrettyPrint (text, cat)  -- ------------------------------------------------------------------------- -- Terms.                                                                   @@ -36,9 +37,13 @@ data FOL = R String [TermType] deriving (Eq, Ord, Show)  instance Show TermType where-    show (Var v) = "var " ++ show v+    show (Var v) = "vt " ++ show v     show (Fn f ts) = "fApp " ++ show f ++ " " ++ show ts +instance Pretty TermType where+    pretty (Var v) = pretty v+    pretty (Fn f ts) = cat ([pretty f, text "("] ++ intersperse (text ", ") (map pretty ts) ++ [text ")"])+ instance Apply FOL String TermType where     foldApply f tf (R p ts) = maybe (f p ts) tf (asBool p)     apply' = R@@ -47,10 +52,21 @@ instance Constants String where     fromBool True = "true"     fromBool False = "false"+    asBool x +        | x == fromBool True = Just True+        | x == fromBool False = Just False+        | True = Nothing  instance Constants FOL where     fromBool x = R (fromBool x) []+    asBool (R p _) = asBool p +instance Predicate String++{-+instance Pretty String where+    pretty = text+ instance FirstOrderFormula (Formula FOL) FOL String where     -- type C.Term (Formula FOL) = Term     -- type V (Formula FOL) = String@@ -74,7 +90,11 @@           Iff fm1 fm2 -> co (BinOp fm1 (:<=>:) fm2)           H.Forall v fm' -> qu C.Forall v fm'           H.Exists v fm' -> qu C.Exists v fm'+-} +instance Pretty FOL where+    pretty (R p ts) = cat ([pretty p, text "("] ++ intersperse (text ", ") (map pretty ts) ++ [text ")"])+ instance Arity String where     arity _ = Nothing @@ -82,13 +102,19 @@ -- something a little more type safe because of our Skolem class. data Function     = FName String-    | Skolem Int+    | Skolem String     deriving (Eq, Ord, Data, Typeable, Show) -instance Skolem Function where+instance Pretty Function where+    pretty (FName s) = text s+    pretty (Skolem v) = text ("sK" ++ v)++instance C.Function Function String++instance Skolem Function String where     toSkolem = Skolem-    fromSkolem (Skolem n) = Just n-    fromSkolem _ = Nothing+    isSkolem (Skolem _) = True+    isSkolem _ = False  instance Term TermType String Function where     -- type V Term = String@@ -99,10 +125,5 @@     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+instance HasFixity FOL where+    fixity = const (Fixity 10 InfixN)
Data/Logic/Types/Harrison/Formulas/FirstOrder.hs view
@@ -1,12 +1,19 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, DeriveDataTypeable, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, DeriveDataTypeable, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables,+             TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} {-# OPTIONS_GHC -Wall -Wwarn #-} module Data.Logic.Types.Harrison.Formulas.FirstOrder     ( Formula(..)     ) where -import Data.Logic.Classes.Combine (Combinable(..))+--import Data.Char (isDigit)+import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..)) import Data.Logic.Classes.Constants (Constants(..))+import Data.Logic.Classes.FirstOrder (FirstOrderFormula(..), prettyFirstOrder, foldAtomsFirstOrder, mapAtomsFirstOrder)+import qualified Data.Logic.Classes.FirstOrder as C+import qualified Data.Logic.Classes.Formula as C import Data.Logic.Classes.Negate (Negatable(..))+import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity)+import Data.Logic.Types.Common ({- instance Variable String -})  data Formula a     = F@@ -31,9 +38,36 @@ instance Constants (Formula a) where     fromBool True = T     fromBool False = F+    asBool T = Just True+    asBool F = Just False+    asBool _ = Nothing  instance Combinable (Formula a) where     a .<=>. b = Iff a b     a .=>. b = Imp a b     a .|. b = Or a b     a .&. b = And a b++instance (Constants a, Pretty a, HasFixity a) => C.Formula (Formula a) a where+    atomic = Atom+    foldAtoms = foldAtomsFirstOrder+    mapAtoms = mapAtomsFirstOrder++instance (C.Formula (Formula a) a, Constants a, Pretty a, HasFixity a) => FirstOrderFormula (Formula a) a String where+    for_all = Forall+    exists = Exists+    foldFirstOrder qu co tf at fm =+        case fm of+          F -> tf False+          T -> tf True+          Atom atom -> at atom+          Not fm' -> co ((:~:) fm')+          And fm1 fm2 -> co (BinOp fm1 (:&:) fm2)+          Or fm1 fm2 -> co (BinOp fm1 (:|:) fm2)+          Imp fm1 fm2 -> co (BinOp fm1 (:=>:) fm2)+          Iff fm1 fm2 -> co (BinOp fm1 (:<=>:) fm2)+          Forall v fm' -> qu C.Forall v fm'+          Exists v fm' -> qu C.Exists v fm'++instance (FirstOrderFormula (Formula a) a String) => Pretty (Formula a) where+    pretty = prettyFirstOrder (const pretty) pretty 0
Data/Logic/Types/Harrison/Formulas/Propositional.hs view
@@ -6,8 +6,11 @@  import Data.Logic.Classes.Constants (Constants(..)) import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..))+import qualified Data.Logic.Classes.Formula as C+import Data.Logic.Classes.Literal (Literal(..)) import Data.Logic.Classes.Negate (Negatable(..))-import Data.Logic.Classes.Propositional (PropositionalFormula(..))+import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), topFixity)+import Data.Logic.Classes.Propositional (PropositionalFormula(..), prettyPropositional, fixityPropositional, foldAtomsPropositional, mapAtomsPropositional)  data Formula a     = F@@ -30,6 +33,9 @@ instance Constants (Formula a) where     fromBool True = T     fromBool False = F+    asBool T = Just True+    asBool F = Just False+    asBool _ = Nothing  instance Combinable (Formula a) where     a .<=>. b = Iff a b@@ -37,9 +43,13 @@     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.+instance (Pretty atom, HasFixity atom, Ord atom) => C.Formula (Formula atom) atom where     atomic = Atom+    foldAtoms = foldAtomsPropositional+    mapAtoms = mapAtomsPropositional++instance (Combinable (Formula atom), Pretty atom, HasFixity atom, Ord atom) => PropositionalFormula (Formula atom) atom where+    -- The atom type for this formula is the same as its first type parameter.     foldPropositional co tf at formula =         case formula of           T -> tf True@@ -50,3 +60,18 @@           Imp f g -> co (BinOp f (:=>:) g)           Iff f g -> co (BinOp f (:<=>:) g)           Atom x -> at x++instance (HasFixity atom, Pretty atom, Ord atom) => Literal (Formula atom) atom where+    foldLiteral neg tf at formula =+        case formula of+          T -> tf True+          F -> tf False+          Not f -> neg f+          Atom x -> at x+          _ -> error ("Unexpected literal " ++ show (pretty formula))++instance (Pretty atom, HasFixity atom, Ord atom) => Pretty (Formula atom) where+    pretty = prettyPropositional pretty topFixity++instance (Pretty atom, HasFixity atom, Ord atom) => HasFixity (Formula atom) where+    fixity = fixityPropositional
Data/Logic/Types/Harrison/Prop.hs view
@@ -1,13 +1,16 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,+             ScopedTypeVariables, TypeFamilies, TypeSynonymInstances #-} {-# OPTIONS_GHC -Wall -Wwarn #-} module Data.Logic.Types.Harrison.Prop     ( Prop(..)     ) where  import Data.Generics (Data, Typeable)-import Data.Logic.Classes.Propositional+import Data.Logic.Classes.Pretty+import Data.Logic.Classes.Propositional (showPropositional) import Data.Logic.Types.Harrison.Formulas.Propositional (Formula(..)) import Prelude hiding (negate)+import Text.PrettyPrint (text)  -- ========================================================================= -- Basic stuff for propositional logic: datatype, parsing and printing.     @@ -17,6 +20,15 @@  instance Show Prop where     show x = "P " ++ show (pname x)++instance Pretty Prop where+    pretty = text . pname++instance HasFixity String where+    fixity = const botFixity++instance HasFixity Prop where+    fixity = const botFixity  instance Show (Formula Prop) where     show = showPropositional show
Data/Logic/Types/Propositional.hs view
@@ -1,16 +1,21 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} module Data.Logic.Types.Propositional where  import Data.Generics (Data, Typeable) import Data.Logic.Classes.Combine (Combinable(..), Combination(..), BinOp(..)) import Data.Logic.Classes.Constants (Constants(..), asBool)+import qualified Data.Logic.Classes.Formula as C+import Data.Logic.Classes.Literal (Literal(..)) import Data.Logic.Classes.Negate (Negatable(..))-import Data.Logic.Classes.Propositional (PropositionalFormula(..))+import Data.Logic.Classes.Pretty (Pretty(pretty), HasFixity(..), topFixity)+import Data.Logic.Classes.Propositional (PropositionalFormula(..), prettyPropositional, fixityPropositional, foldAtomsPropositional, mapAtomsPropositional)  -- | The range of a formula is {True, False} when it has no free variables. data Formula atom     = Combine (Combination (Formula atom))     | Atom atom+    | T+    | F     -- Note that a derived Eq instance is not going to tell us that     -- a&b is equal to b&a, let alone that ~(a&b) equals (~a)|(~b).     deriving (Eq,Ord,Data,Typeable)@@ -20,18 +25,44 @@     foldNegation normal inverted (Combine ((:~:) x)) = foldNegation inverted normal x     foldNegation normal _ x = normal x -instance (Constants atom, Ord atom) => Combinable (Formula atom) where+instance (Ord atom) => Combinable (Formula atom) where     x .<=>. y = Combine (BinOp  x (:<=>:) y)     x .=>.  y = Combine (BinOp  x (:=>:)  y)     x .|.   y = Combine (BinOp  x (:|:)   y)     x .&.   y = Combine (BinOp  x (:&:)   y) -instance Constants atom => Constants (Formula atom) where-    fromBool = Atom . fromBool -instance (Constants atom, Ord atom) => PropositionalFormula (Formula atom) atom where-    atomic a = Atom a+instance Constants (Formula atom) where+    fromBool True = T+    fromBool False = F+    asBool T = Just True+    asBool F = Just False+    asBool _ = Nothing++instance (Pretty atom, HasFixity atom, Ord atom) => C.Formula (Formula atom) atom where+    atomic = Atom+    foldAtoms = foldAtomsPropositional+    mapAtoms = mapAtomsPropositional++instance (Pretty atom, HasFixity atom, Ord atom) => Literal (Formula atom) atom where+    foldLiteral neg tf at formula =+        case formula of+          Combine ((:~:) p) -> neg p+          Combine _ -> error ("Unexpected literal: " ++ show (pretty formula))+          Atom x -> at x+          T -> tf True+          F -> tf False++instance (C.Formula (Formula atom) atom, Pretty atom, HasFixity atom, Ord atom) => PropositionalFormula (Formula atom) atom where     foldPropositional co tf at formula =         case formula of           Combine x -> co x-          Atom x -> maybe (at x) tf (asBool x)+          Atom x -> at x+          T -> tf True+          F -> tf False++instance (Pretty atom, HasFixity atom, Ord atom) => Pretty (Formula atom) where+    pretty = prettyPropositional pretty topFixity++instance (Pretty atom, HasFixity atom, Ord atom) => HasFixity (Formula atom) where+    fixity = fixityPropositional
logic-classes.cabal view
@@ -1,42 +1,51 @@ Name:             logic-classes-Version:          1.1-License:          BSD3-Author:           David Fox <dsf@seereason.com>-Maintainer:       SeeReason Partners <partners@seereason.com>-Synopsis:         Support for propositional and first order logic, normal forms, and a resolution theorem prover.+Version:          1.4+Synopsis:         Framework for propositional and first order logic, theorem proving Description:      Package to support Propositional and First Order Logic.  It includes classes                   representing the different types of formulas and terms, some instances of                   those classes for types used in other logic libraries, and implementations of                   several logic algorithms, including conversion to normal form and a simple                   resolution-based theorem prover for any instance of FirstOrderFormula.-Build-Type:       Custom+Homepage:         http://src.seereason.com/logic-classes+License:          BSD3+Author:           David Fox <dsf@seereason.com>+Maintainer:       SeeReason Partners <partners@seereason.com>+Bug-Reports:      http://bugzilla.seereason.com/ Category:         Logic, Theorem Provers-Cabal-version:    >= 1.2+Cabal-version:    >= 1.6+Build-Type:       Simple  Library  GHC-options: -Wall -O2- Exposed-Modules:  Data.Logic.Classes.Arity-                   Data.Logic.Classes.Apply+ Exposed-Modules:  Data.Logic.Classes.Apply+                   Data.Logic.Classes.Arity+                   Data.Logic.Classes.Atom                    Data.Logic.Classes.ClauseNormalForm                    Data.Logic.Classes.Combine                    Data.Logic.Classes.Constants                    Data.Logic.Classes.Equals                    Data.Logic.Classes.FirstOrder+                   Data.Logic.Classes.Formula                    Data.Logic.Classes.Literal                    Data.Logic.Classes.Negate+                   Data.Logic.Classes.Pretty                    Data.Logic.Classes.Propositional                    Data.Logic.Classes.Skolem                    Data.Logic.Classes.Term                    Data.Logic.Classes.Variable+                   Data.Logic.Harrison.DefCNF+                   Data.Logic.Harrison.DP                    Data.Logic.Harrison.Equal                    Data.Logic.Harrison.FOL                    Data.Logic.Harrison.Formulas.FirstOrder                    Data.Logic.Harrison.Formulas.Propositional+                   Data.Logic.Harrison.Herbrand                    Data.Logic.Harrison.Lib                    Data.Logic.Harrison.Meson                    Data.Logic.Harrison.Normal                    Data.Logic.Harrison.Prolog                    Data.Logic.Harrison.Prop+                   Data.Logic.Harrison.PropExamples                    Data.Logic.Harrison.Resolution                    Data.Logic.Harrison.Skolem                    Data.Logic.Harrison.Tableaux@@ -44,11 +53,14 @@                    Data.Logic.Instances.Chiou                    Data.Logic.Instances.PropLogic                    Data.Logic.Instances.SatSolver+                   -- Data.Logic.Instances.TPTP                    Data.Logic.KnowledgeBase                    Data.Logic.Normal.Clause                    Data.Logic.Normal.Implicative                    Data.Logic.Resolution                    Data.Logic.Satisfiable+                   Data.Logic.Tests.HUnit+                   Data.Logic.Types.Common                    Data.Logic.Types.FirstOrder                    Data.Logic.Types.FirstOrderPublic                    Data.Logic.Types.Harrison.Equal@@ -58,7 +70,7 @@                    Data.Logic.Types.Harrison.Prop                    Data.Logic.Types.Propositional  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+                   mtl, syb-with-class, text, PropLogic, pretty, safecopy, set-extra, syb, template-haskell  Executable tests  GHC-Options: -Wall -O2@@ -69,9 +81,9 @@                    Data.Logic.Tests.Data                    Data.Logic.Tests.Logic                    Data.Logic.Tests.TPTP+                   Data.Logic.Tests.Harrison.Common                    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