packages feed

atp-haskell (empty) → 1.7

raw patch · 31 files changed

+9433/−0 lines, 31 filesdep +HUnitdep +atp-haskelldep +basesetup-changed

Dependencies added: HUnit, atp-haskell, base, containers, mtl, parsec, pretty, template-haskell, time

Files

+ .ghci view
@@ -0,0 +1,8 @@+:set -isrc:tests+:set -XCPP+:set -XOverloadedStrings+:set -XFlexibleContexts+:set -XFlexibleInstances+:set -XQuasiQuotes+:set prompt "λ "+:load Data.Logic.ATP
+ .travis.yml view
@@ -0,0 +1,44 @@+sudo: false++matrix:+  include:+    - env: CABALVER=1.22 GHCVER=7.10.2+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2],sources: [hvr-ghc]}}+    - env: CABALVER=head GHCVER=head+      addons: {apt: {packages: [cabal-install-head,ghc-head],  sources: [hvr-ghc]}}++  allow_failures:+   - env: CABALVER=head GHCVER=head++before_install:+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH++install:+ - cabal --version+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"+ - travis_retry cabal update+ - cabal install --only-dependencies --enable-tests --enable-benchmarks++# Here starts the actual work to be performed for the package under+# test; any command which exits with a non-zero exit code causes the+# build to fail.++script:+ - cabal configure --enable-tests -v2  # -v2 provides useful information for debugging+ - cabal build   # this builds all libraries and executables (including tests/benchmarks)+ - cabal test+ # - cabal check+ - cabal sdist   # tests that a source-distribution can be generated++# The following scriptlet checks that the resulting source distribution can be built & installed+ - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;+   cd dist/;+   if [ -f "$SRC_TGZ" ]; then+      cabal install --force-reinstalls "$SRC_TGZ";+   else+      echo "expected '$SRC_TGZ' not found";+      exit 1;+   fi++after_script:+  - cat dist/test/*.log
+ LICENSE.txt view
@@ -0,0 +1,35 @@+IMPORTANT:  READ BEFORE DOWNLOADING, COPYING, INSTALLING OR USING.+By downloading, copying, installing or using the software you agree+to this license.  If you do not agree to this license, do not+download, install, copy or use the software.++Copyright (c) 2003-2007, John Harrison+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++* Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++* The name of John Harrison may not be used to endorse or promote+products derived from this software without specific prior written+permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF+USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT+OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ atp-haskell.cabal view
@@ -0,0 +1,94 @@+Name:             atp-haskell+Version:          1.7+Synopsis:         Translation from Ocaml to Haskell of John Harrison's ATP code+Description:      This package is a liberal translation from OCaml to Haskell of+                  the automated theorem prover written in OCaml in+                  John Harrison's book "Practical Logic and Automated+                  Reasoning".  Click on module ATP below for an overview.+Homepage:         https://github.com/seereason/atp-haskell+License:          BSD3+License-File:     LICENSE.txt+Author:           John Harrison+Maintainer:       David Fox <dsf@seereason.com>+Bug-Reports:      https://github.com/seereason/atp-haskell/issues+Category:         Logic, Theorem Provers+Cabal-version:    >= 1.9+Build-Type:       Simple+Extra-Source-Files: tests/Extra.hs, .travis.yml, .ghci++Source-Repository head+  type: git+  location: https://github.com/seereason/atp-haskell++Library+  Build-Depends:+    base >= 4.8 && < 5,+    containers,+    HUnit,+    mtl,+    parsec,+    pretty >= 1.1.2,+    template-haskell,+    time+  GHC-options: -Wall -O2+  Hs-Source-Dirs: src+  Exposed-Modules:+    Data.Logic.ATP+    Data.Logic.ATP.Lib+    Data.Logic.ATP.Pretty+    Data.Logic.ATP.Formulas+    Data.Logic.ATP.Term+    Data.Logic.ATP.Apply+    Data.Logic.ATP.Equate+    --+    Data.Logic.ATP.Lit+    Data.Logic.ATP.Prop+    Data.Logic.ATP.PropExamples+    Data.Logic.ATP.DefCNF+    Data.Logic.ATP.DP+    -- Data.Logic.ATP.Stal+    -- Data.Logic.ATP.BDD+    Data.Logic.ATP.Quantified+    Data.Logic.ATP.Parser+    Data.Logic.ATP.FOL+    Data.Logic.ATP.ParserTests+    Data.Logic.ATP.Skolem+    Data.Logic.ATP.Herbrand+    Data.Logic.ATP.Unif+    Data.Logic.ATP.Tableaux+    Data.Logic.ATP.Resolution+    Data.Logic.ATP.Prolog+    Data.Logic.ATP.Meson+    -- Data.Logic.ATP.Skolems+    Data.Logic.ATP.Equal+    -- Data.Logic.ATP.Cong+    -- Data.Logic.ATP.Rewrite+    -- Data.Logic.ATP.Order+    -- Data.Logic.ATP.Completion+    -- Data.Logic.ATP.Eqelim+    -- Data.Logic.ATP.Paramodulation+    --+    -- Data.Logic.ATP.Decidable+    -- Data.Logic.ATP.Qelim+    -- Data.Logic.ATP.Cooper+    -- Data.Logic.ATP.Complex+    -- Data.Logic.ATP.Real+    -- Data.Logic.ATP.Grobner+    -- Data.Logic.ATP.Geom+    -- Data.Logic.ATP.Interpolation+    -- Data.Logic.ATP.Combining++    -- Data.Logic.ATP.Lcf+    -- Data.Logic.ATP.Lcfprop+    -- Data.Logic.ATP.Folderived+    -- Data.Logic.ATP.Lcffol+    -- Data.Logic.ATP.Tactics++    -- Data.Logic.ATP.Limitations++Test-Suite atp-haskell-tests+  Type: exitcode-stdio-1.0+  Hs-Source-Dirs: tests+  Main-Is: Main.hs+  Build-Depends: atp-haskell, base, containers, HUnit, time+  GHC-options: -Wall -O2
+ src/Data/Logic/ATP.hs view
@@ -0,0 +1,53 @@+module Data.Logic.ATP+    ( module Data.Logic.ATP.Lib+    , module Data.Logic.ATP.Pretty+    , module Data.Logic.ATP.Formulas+    , module Data.Logic.ATP.Lit+    , module Data.Logic.ATP.Prop+    , module Data.Logic.ATP.PropExamples+    , module Data.Logic.ATP.DefCNF+    , module Data.Logic.ATP.DP+    , module Data.Logic.ATP.Term+    , module Data.Logic.ATP.Apply+    , module Data.Logic.ATP.Equate+    , module Data.Logic.ATP.Quantified+    , module Data.Logic.ATP.Parser+    , module Data.Logic.ATP.FOL+    , module Data.Logic.ATP.Skolem+    , module Data.Logic.ATP.Herbrand+    , module Data.Logic.ATP.Unif+    , module Data.Logic.ATP.Tableaux+    , module Data.Logic.ATP.Resolution+    , module Data.Logic.ATP.Prolog+    , module Data.Logic.ATP.Meson+    , module Data.Logic.ATP.Equal+    , module Text.PrettyPrint.HughesPJClass+    , module Test.HUnit+    ) where++import Data.String ({-instances-})+import Text.PrettyPrint.HughesPJClass hiding ((<>))++import Data.Logic.ATP.Lib+import Data.Logic.ATP.Pretty+import Data.Logic.ATP.Formulas+import Data.Logic.ATP.Lit hiding (Atom, T, F, Not)+import Data.Logic.ATP.Prop hiding (Atom, nnf, T, F, Not, And, Or, Imp, Iff)+import Data.Logic.ATP.PropExamples hiding (K)+import Data.Logic.ATP.DefCNF+import Data.Logic.ATP.DP+import Data.Logic.ATP.Term+import Data.Logic.ATP.Apply+import Data.Logic.ATP.Equate+import Data.Logic.ATP.Quantified+import Data.Logic.ATP.Parser+import Data.Logic.ATP.FOL+import Data.Logic.ATP.Skolem+import Data.Logic.ATP.Herbrand+import Data.Logic.ATP.Unif+import Data.Logic.ATP.Tableaux hiding (K)+import Data.Logic.ATP.Resolution+import Data.Logic.ATP.Prolog+import Data.Logic.ATP.Meson+import Data.Logic.ATP.Equal+import Test.HUnit
+ src/Data/Logic/ATP/Apply.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Data.Logic.ATP.Apply+    ( IsPredicate+    , HasApply(TermOf, PredOf, applyPredicate, foldApply', overterms, onterms)+    , atomFuncs+    , functions+    , JustApply+    , foldApply+    , prettyApply+    , overtermsApply+    , ontermsApply+    , zipApplys+    , showApply+    , convertApply+    , onformula+    , pApp+    , FOLAP(AP)+    , Predicate+    , ApAtom+    ) where++import Data.Data (Data)+import Data.Logic.ATP.Formulas (IsAtom, IsFormula(..), onatoms)+import Data.Logic.ATP.Pretty as Pretty ((<>), Associativity(InfixN), Doc, HasFixity(associativity, precedence), pAppPrec, text)+import Data.Logic.ATP.Term (Arity, FTerm, IsTerm(FunOf, TVarOf), funcs)+import Data.Set as Set (Set, union)+import Data.String (IsString(fromString))+import Data.Typeable (Typeable)+import Prelude hiding (pred)+import Text.PrettyPrint (parens, brackets, punctuate, comma, fcat, space)+import Text.PrettyPrint.HughesPJClass (Pretty(pPrint))++---------------------------+-- ATOMS (Atomic Formula) AND PREDICATES --+---------------------------++-- | A predicate is the thing we apply to a list of 'IsTerm's to make+-- an 'IsAtom'.+class (Eq predicate, Ord predicate, Show predicate, IsString predicate, Pretty predicate) => IsPredicate predicate++class (IsAtom atom, IsPredicate (PredOf atom), IsTerm (TermOf atom)) => HasApply atom where+    type PredOf atom+    type TermOf atom+    applyPredicate :: PredOf atom -> [(TermOf atom)] -> atom+    foldApply' :: (atom -> r) -> (PredOf atom -> [(TermOf atom)] -> r) -> atom -> r+    overterms :: ((TermOf atom) -> r -> r) -> r -> atom -> r+    onterms :: ((TermOf atom) -> (TermOf atom)) -> atom -> atom++-- | The set of functions in an atom.+atomFuncs :: (HasApply atom, function ~ FunOf (TermOf atom)) => atom -> Set (function, Arity)+atomFuncs = overterms (Set.union . funcs) mempty++-- | The set of functions in a formula.+functions :: (IsFormula formula, HasApply atom, Ord function,+              atom ~ AtomOf formula,+              term ~ TermOf atom,+              function ~ FunOf term) =>+             formula -> Set (function, Arity)+functions fm = overatoms (Set.union . atomFuncs) fm mempty++-- | Atoms that have apply but do not support equate+class HasApply atom => JustApply atom++foldApply :: (JustApply atom, term ~ TermOf atom) => (PredOf atom -> [term] -> r) -> atom -> r+foldApply = foldApply' (error "JustApply failure")++-- | Pretty print prefix application of a predicate+prettyApply :: (v ~ TVarOf term, IsPredicate predicate, IsTerm term) => predicate -> [term] -> Doc+prettyApply p ts = pPrint p <> parens (fcat (punctuate comma (map pPrint ts)))++-- | Implementation of 'overterms' for 'HasApply' types.+overtermsApply :: JustApply atom => ((TermOf atom) -> r -> r) -> r -> atom -> r+overtermsApply f r0 = foldApply (\_ ts -> foldr f r0 ts)++-- | Implementation of 'onterms' for 'HasApply' types.+ontermsApply :: JustApply atom => ((TermOf atom) -> (TermOf atom)) -> atom -> atom+ontermsApply f = foldApply (\p ts -> applyPredicate p (map f ts))++-- | Zip two atoms if they are similar+zipApplys :: (JustApply atom, term ~ TermOf atom, predicate ~ PredOf atom) =>+                 (predicate -> [(term, term)] -> Maybe r) -> atom -> atom -> Maybe r+zipApplys f atom1 atom2 =+    foldApply f' atom1+    where+      f' p1 ts1 = foldApply (\p2 ts2 ->+                                     if p1 /= p2 || length ts1 /= length ts2+                                     then Nothing+                                     else f p1 (zip ts1 ts2)) atom2++-- | Implementation of 'Show' for 'JustApply' types+showApply :: (Show predicate, Show term) => predicate -> [term] -> String+showApply p ts = show (text "pApp " <> parens (text (show p)) <> brackets (fcat (punctuate (comma <> space) (map (text . show) ts))))++-- | Convert between two instances of 'HasApply'+convertApply :: (JustApply atom1, HasApply atom2) =>+                (PredOf atom1 -> PredOf atom2) -> (TermOf atom1 -> TermOf atom2) -> atom1 -> atom2+convertApply cp ct = foldApply (\p1 ts1 -> applyPredicate (cp p1) (map ct ts1))++-- | Special case of applying a subfunction to the top *terms*.+onformula :: (IsFormula formula, HasApply atom, atom ~ AtomOf formula, term ~ TermOf atom) =>+             (term -> term) -> formula -> formula+onformula f = onatoms (onterms f)++-- | Build a formula from a predicate and a list of terms.+pApp :: (IsFormula formula, HasApply atom, atom ~ AtomOf formula) => PredOf atom -> [TermOf atom] -> formula+pApp p args = atomic (applyPredicate p args)++-- | First order logic formula atom type.+data FOLAP predicate term = AP predicate [term] deriving (Eq, Ord, Data, Typeable, Read)++instance (IsPredicate predicate, IsTerm term) => JustApply (FOLAP predicate term)++instance (IsPredicate predicate, IsTerm term) => IsAtom (FOLAP predicate term)++instance (IsPredicate predicate, IsTerm term) => Pretty (FOLAP predicate term) where+    pPrint = foldApply prettyApply++instance (IsPredicate predicate, IsTerm term) => HasApply (FOLAP predicate term) where+    type PredOf (FOLAP predicate term) = predicate+    type TermOf (FOLAP predicate term) = term+    applyPredicate = AP+    foldApply' _ f (AP p ts) = f p ts+    overterms f r (AP _ ts) = foldr f r ts+    onterms f (AP p ts) = AP p (map f ts)++instance (IsPredicate predicate, IsTerm term, Show predicate, Show term) => Show (FOLAP predicate term) where+    show = foldApply (\p ts -> showApply (p :: predicate) (ts :: [term]))++instance HasFixity (FOLAP predicate term) where+    precedence _ = pAppPrec+    associativity _ = Pretty.InfixN++-- | A predicate type with no distinct equality.+data Predicate = NamedPred String+    deriving (Eq, Ord, Data, Typeable, Read)++instance IsString Predicate where++    -- fromString "True" = error "bad predicate name: True"+    -- fromString "False" = error "bad predicate name: True"+    -- fromString "=" = error "bad predicate name: True"+    fromString s = NamedPred s++instance Show Predicate where+    show (NamedPred s) = "fromString " ++ show s++instance Pretty Predicate where+    pPrint (NamedPred "=") = error "Use of = as a predicate name is prohibited"+    pPrint (NamedPred "True") = error "Use of True as a predicate name is prohibited"+    pPrint (NamedPred "False") = error "Use of False as a predicate name is prohibited"+    pPrint (NamedPred s) = text s++instance IsPredicate Predicate++-- | An atom type with no equality predicate+type ApAtom = FOLAP Predicate FTerm+instance JustApply ApAtom
+ src/Data/Logic/ATP/DP.hs view
@@ -0,0 +1,247 @@+-- | The Davis-Putnam and Davis-Putnam-Loveland-Logemann procedures.+--+-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Logic.ATP.DP+    ( dp,   dpsat,   dptaut+    , dpli, dplisat, dplitaut+    , dpll, dpllsat, dplltaut+    , dplb, dplbsat, dplbtaut+    , testDP+    ) where++import Data.Logic.ATP.DefCNF (NumAtom(ai, ma), defcnfs)+import Data.Logic.ATP.Formulas (IsFormula(AtomOf))+import Data.Logic.ATP.Lib (Failing(Success, Failure), failing, allpairs, minimize, maximize, defined, (|->), setmapfilter, flatten)+import Data.Logic.ATP.Lit (IsLiteral, (.~.), negative, positive, negate, negated)+import Data.Logic.ATP.Prop (trivial, JustPropositional, PFormula)+import Data.Logic.ATP.PropExamples (Knows(K), prime)+import Data.Map.Strict as Map (empty, Map)+import Data.Set as Set (delete, difference, empty, filter, findMin, fold, insert, intersection, map, member,+                        minView, null, partition, Set, singleton, size, union)+import Prelude hiding (negate, pure)+import Test.HUnit++instance NumAtom (Knows Integer) where+    ma n = K "p" n Nothing+    ai (K _ n _) = n++-- | The DP procedure.+dp :: (IsLiteral lit, Ord lit) => Set (Set lit) -> Bool+dp clauses+  | Set.null clauses = True+  | Set.member Set.empty clauses = False+  | otherwise = try1+  where+    try1 :: Bool+    try1 = failing (const try2) dp (one_literal_rule clauses)+    try2 :: Bool+    try2 = failing (const try3) dp (affirmative_negative_rule clauses)+    try3 :: Bool+    try3 = dp (resolution_rule clauses)++one_literal_rule :: (IsLiteral lit, Ord lit) => Set (Set lit) -> Failing (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 :: (IsLiteral lit, Ord lit) => Set (Set lit) -> Failing (Set (Set lit))+affirmative_negative_rule clauses =+  let (neg',pos) = Set.partition negative (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 :: (IsLiteral lit, Ord lit) => lit -> Set (Set lit) -> 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 :: (IsLiteral lit, Ord lit) => Set (Set lit) -> lit -> 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 :: (IsLiteral lit, Ord lit) => Set (Set lit) -> Set (Set lit)+resolution_rule clauses = resolve_on p clauses+    where+      pvs = Set.filter positive (flatten clauses)+      Just p = minimize (resolution_blowup clauses) pvs++-- | Davis-Putnam satisfiability tester.+dpsat :: (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Bool+dpsat = dp . defcnfs++-- | Davis-Putnam tautology checker.+dptaut :: (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Bool+dptaut = not . dpsat . negate++-- Examples.++test01 :: Test+test01 = TestCase (assertEqual "dptaut(prime 11) p. 84" True (dptaut (prime 11 :: PFormula (Knows Integer))))++-- | The same thing but with the DPLL procedure. (p. 84)+dpll :: (IsLiteral lit, Ord lit) => Set (Set lit) -> Bool+dpll clauses+  | Set.null clauses = True+  | Set.member Set.empty clauses = False+  | otherwise = try1+  where+    try1 = failing (const try2) dpll (one_literal_rule clauses)+    try2 = failing (const try3) dpll (affirmative_negative_rule clauses)+    try3 = dpll (Set.insert (Set.singleton p) clauses) || dpll (Set.insert (Set.singleton (negate p)) clauses)+    Just p = maximize (posneg_count clauses) pvs+    pvs = Set.filter positive (flatten clauses)+{-+  | failing (const try3)+  | otherwise =+      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 (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 (negate 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+-}++posneg_count :: (IsLiteral formula, Ord formula) => 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 (negate l)) cls) in+  m + n++dpllsat :: (JustPropositional pf, Ord pf, AtomOf pf ~ Knows Integer) => pf -> Bool+dpllsat = dpll . defcnfs++dplltaut :: (JustPropositional pf, Ord pf, AtomOf pf ~ Knows Integer) => pf -> Bool+dplltaut = not . dpllsat . negate++-- Example.+test02 :: Test+test02 = TestCase (assertEqual "dplltaut(prime 11)" True (dplltaut (prime 11 :: PFormula (Knows Integer))))++-- | Iterative implementation with explicit trail instead of recursion.+dpli :: (IsLiteral formula, Ord formula) => Set (formula, TrailMix) -> Set (Set formula) -> Bool+dpli trail cls =+  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 (Set.insert (negate p, Deduced) tt) cls+      _ -> False+  else+      case unassigned cls (trail' {-:: Set (pf, TrailMix)-}) of+        s | Set.null s -> True+        ps -> let Just p = maximize (posneg_count cls') ps in+              dpli (Set.insert (p {-:: pf-}, Guessed) trail') cls++data TrailMix = Guessed | Deduced deriving (Eq, Ord)++unassigned :: (IsLiteral formula, Ord formula, Eq formula) => Set (Set formula) -> Set (formula, TrailMix) -> Set formula+unassigned cls trail =+    Set.difference (flatten (Set.map (Set.map litabs) cls)) (Set.map (litabs . fst) trail)+    where litabs p = if negated p then negate p else p++unit_subpropagate :: (IsLiteral formula, Ord formula) =>+                     (Set (Set formula), Map formula (), Set (formula, TrailMix))+                  -> (Set (Set formula), Map formula (), Set (formula, TrailMix))+unit_subpropagate (cls,fn,trail) =+  let cls' = Set.map (Set.filter (not . defined fn . negate)) 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 = 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. (IsLiteral t, Ord t) =>+                  (Set (Set t), Set (t, TrailMix))+               -> (Set (Set t), 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 (t, TrailMix) -> Set (t, TrailMix)+backtrack trail =+  case Set.minView trail of+    Just ((_p,Deduced), tt) -> backtrack tt+    _ -> trail++dplisat :: (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Bool+dplisat = dpli Set.empty . defcnfs++dplitaut :: (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Bool+dplitaut = not . dplisat . negate++-- | With simple non-chronological backjumping and learning.+dplb :: (IsLiteral formula, Ord formula) => Set (formula, TrailMix) -> Set (Set formula) -> Bool+dplb trail cls =+  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 (negate p) (Set.map (negate . fst) declits) in+        dplb (Set.insert (negate p, Deduced) trail'') (Set.insert conflict cls)+      _ -> False+  else+    case unassigned cls trail' of+      s | Set.null s -> True+      ps -> let Just p = maximize (posneg_count cls') ps in+            dplb (Set.insert (p,Guessed) trail') cls++backjump :: (IsLiteral a, Ord a) => Set (Set a) -> a -> Set (a, TrailMix) -> 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++dplbsat :: (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Bool+dplbsat = dplb Set.empty . defcnfs++dplbtaut :: (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Bool+dplbtaut = not . dplbsat . negate++-- | Examples.+test03 :: Test+test03 = TestList [TestCase (assertEqual "dplitaut(prime 101)" True (dplitaut (prime 101 :: PFormula (Knows Integer)))),+                   TestCase (assertEqual "dplbtaut(prime 101)" True (dplbtaut (prime 101 :: PFormula (Knows Integer))))]++testDP :: Test+testDP = TestLabel "DP" (TestList [test01, test02, test03])
+ src/Data/Logic/ATP/DefCNF.hs view
@@ -0,0 +1,201 @@+-- | Definitional CNF.+--+-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Logic.ATP.DefCNF+    ( NumAtom(ma, ai)+    , defcnfs+    , defcnf1+    , defcnf2+    , defcnf3+    -- * Instance+    , Atom(N)+    -- * Tests+    , testDefCNF+    ) where++import Data.Function (on)+import Data.List as List+import Data.Logic.ATP.Formulas as P+import Data.Logic.ATP.Lit ((.~.), (¬), convertLiteral, IsLiteral, JustLiteral, LFormula)+import Data.Logic.ATP.Pretty (assertEqual', HasFixity, Pretty(pPrint), prettyShow, text)+import Data.Logic.ATP.Prop (cnf', foldPropositional, IsPropositional(foldPropositional'), JustPropositional,+                            list_conj, list_disj, nenf, PFormula, Prop(P), simpcnf,+                            (∨), (∧), (.<=>.), (.&.), (.|.), BinOp(..))+import Data.Map.Strict as Map hiding (fromList)+import Data.Set as Set+import Test.HUnit++-- | Example (p. 74)+test01 :: Test+test01 =+    let p :: PFormula Prop+        q :: PFormula Prop+        r :: PFormula Prop+        [p, q, r] = (List.map (atomic . P) ["p", "q", "r"]) in+    TestCase $ assertEqual' "cnf test (p. 74)"+                 ((p∨q∨r)∧(p∨(¬)q∨(¬)r)∧(q∨(¬)p∨(¬)r)∧(r∨(¬)p∨(¬)q))+                 (cnf' (p .<=>. (q .<=>. r)) :: PFormula Prop)++class NumAtom atom where+    ma :: Integer -> atom+    ai :: atom -> Integer++data Atom = N String Integer deriving (Eq, Ord, Show)++instance Pretty Atom where+    pPrint (N s n) = text (s ++ if n == 0 then "" else show n)++instance NumAtom Atom where+    ma = N "p_"+    ai (N _ n) = n++instance HasFixity Atom++instance IsAtom Atom++-- | Make a stylized variable and update the index.+mkprop :: forall pf. (IsPropositional pf, NumAtom (AtomOf pf)) => Integer -> (pf, Integer)+mkprop n = (atomic (ma n :: AtomOf pf), n + 1)++-- |  Core definitional CNF procedure.+maincnf :: (IsPropositional pf, Ord pf, NumAtom (AtomOf pf)) => (pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer)+maincnf trip@(fm, _defs, _n) =+    foldPropositional' ho co ne tf at fm+    where+      ho _ = trip+      co p (:&:) q = defstep (.&.) (p,q) trip+      co p (:|:) q = defstep (.|.) (p,q) trip+      co p (:<=>:) q = defstep (.<=>.) (p,q) trip+      co _ (:=>:) _ = trip+      ne _ = trip+      tf _ = trip+      at _ = trip++defstep :: (IsPropositional pf, NumAtom (AtomOf pf), Ord pf) =>+           (pf -> pf -> pf) -> (pf, pf) -> (pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer)+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 -> Integer -> Integer+max_varindex atom n = max n (ai atom)++-- | Overall definitional CNF.+defcnf1 :: forall pf. (IsPropositional pf, JustPropositional pf, NumAtom (AtomOf pf), Ord pf) => pf -> pf+defcnf1 = list_conj . Set.map (list_disj . Set.map (convertLiteral id)) . (mk_defcnf id maincnf :: pf -> Set (Set (LFormula (AtomOf pf))))++mk_defcnf :: forall pf lit.+             (IsPropositional pf, JustPropositional pf,+              IsLiteral lit, JustLiteral lit, Ord lit,+              NumAtom (AtomOf pf)) =>+             (AtomOf pf -> AtomOf lit)+          -> ((pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer))+          -> pf -> Set (Set lit)+mk_defcnf ca fn fm =+  let (fm' :: pf) = 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 (List.map (simpcnf ca :: pf -> Set (Set lit)) (fm'' : deflist))++testfm :: PFormula Atom+testfm = let (p, q, r, s) = (atomic (N "p" 0), atomic (N "q" 0), atomic (N "r" 0), atomic (N "s" 0)) in+     (p .|. (q .&. ((.~.) r))) .&. s++-- Example.+{-+START_INTERACTIVE;;+defcnf1 <<(p \/ (q /\ ~r)) /\ s>>;;+END_INTERACTIVE;;+-}++test02 :: Test+test02 =+    let input = strings (mk_defcnf id maincnf testfm :: Set (Set (LFormula Atom)))+        expected = [["p_3"],+                    ["p_2","¬p"],+                    ["p_2","¬p_1"],+                    ["p_2","¬p_3"],+                    ["q","¬p_1"],+                    ["s","¬p_3"],+                    ["¬p_1","¬r"],+                    ["p","p_1","¬p_2"],+                    ["p_1","r","¬q"],+                    ["p_3","¬p_2","¬s"]] in+    TestCase $ assertEqual "defcnf1 (p. 77)" expected input++strings :: Pretty a => Set (Set a) -> [[String]]+strings ss = sortBy (compare `on` length) . sort . Set.toList $ Set.map (sort . Set.toList . Set.map prettyShow) ss++-- | Version tweaked to exploit initial structure.+defcnf2 :: (IsPropositional pf, JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> pf+defcnf2 fm = list_conj (Set.map (list_disj . Set.map (convertLiteral id)) (defcnfs fm))++defcnfs :: (IsPropositional pf, JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Set (Set (LFormula (AtomOf pf)))+defcnfs fm = mk_defcnf id andcnf fm++andcnf :: (IsPropositional pf, JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => (pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer)+andcnf trip@(fm,_defs,_n) =+    foldPropositional co (\ _ -> orcnf trip) (\ _ -> orcnf trip) (\ _ -> orcnf trip) fm+    where+      co p (:&:) q = subcnf andcnf (.&.) p q trip+      co _ _ _ = orcnf trip++orcnf :: (IsPropositional pf, JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => (pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer)+orcnf trip@(fm,_defs,_n) =+    foldPropositional co (\ _ -> maincnf trip) (\ _ -> maincnf trip) (\ _ -> maincnf trip) fm+    where+      co p (:|:) q = subcnf orcnf (.|.) p q trip+      co _ _ _ = maincnf trip++subcnf :: (IsPropositional pf, NumAtom (AtomOf pf)) =>+          ((pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer))+       -> (pf -> pf -> pf)+       -> pf+       -> pf+       -> (pf, Map pf pf, Integer)+       -> (pf, Map pf pf, Integer)+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)++-- | Version that guarantees 3-CNF.+defcnf3 :: forall pf. (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> pf+defcnf3 = list_conj . Set.map (list_disj . Set.map (convertLiteral id)) . (mk_defcnf id andcnf3 :: pf -> Set (Set (LFormula (AtomOf pf))))++andcnf3 :: (IsPropositional pf, JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => (pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer)+andcnf3 trip@(fm,_defs,_n) =+    foldPropositional co (\ _ -> maincnf trip) (\ _ -> maincnf trip) (\ _ -> maincnf trip) fm+    where+      co p (:&:) q = subcnf andcnf3 (.&.) p q trip+      co _ _ _ = maincnf trip++test03 :: Test+test03 =+    let input = strings (mk_defcnf id andcnf3 testfm :: Set (Set (LFormula Atom)))+        expected = [["p_2"],+                    ["s"],+                    ["p_2","¬p"],+                    ["p_2","¬p_1"],+                    ["q","¬p_1"],+                    ["¬p_1","¬r"],+                    ["p","p_1","¬p_2"],+                    ["p_1","r","¬q"]] in+    TestCase $ assertEqual "defcnf1 (p. 77)" expected input++testDefCNF :: Test+testDefCNF = TestLabel "DefCNF" (TestList [test01, test02, test03])
+ src/Data/Logic/ATP/Equal.hs view
@@ -0,0 +1,461 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+-- | First order logic with equality.+--+-- Copyright (co) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)++{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables, TypeSynonymInstances #-}+{-# OPTIONS_GHC -Wall #-}++module Data.Logic.ATP.Equal+    ( function_congruence+    , equalitize+    -- * Tests+    , wishnu+    , testEqual+    ) where++import Data.Logic.ATP.Apply (functions, HasApply(TermOf, PredOf, applyPredicate), pApp)+import Data.Logic.ATP.Equate ((.=.), HasEquate(foldEquate))+import Data.Logic.ATP.Formulas (IsFormula(AtomOf, atomic), atom_union)+import Data.Logic.ATP.Lib ((∅), Depth(Depth), Failing (Success, Failure), timeMessage)+import Data.Logic.ATP.Meson (meson)+import Data.Logic.ATP.Pretty (assertEqual')+import Data.Logic.ATP.Prop ((.&.), (.=>.), (∧), (⇒))+import Data.Logic.ATP.Quantified ((∃), (∀), IsQuantified(..))+import Data.Logic.ATP.Parser (fof)+import Data.Logic.ATP.Skolem (runSkolem, Formula)+import Data.Logic.ATP.Term (IsTerm(..))+import Data.List as List (foldr, map)+import Data.Set as Set+import Data.String (IsString(fromString))+import Prelude hiding ((*))+import Test.HUnit++-- is_eq :: (IsQuantified fof atom v, IsAtomWithEquate atom p term) => fof -> Bool+-- is_eq = foldFirstOrder (\ _ _ _ -> False) (\ _ -> False) (\ _ -> False) (foldAtomEq (\ _ _ -> False) (\ _ -> False) (\ _ _ -> True))+--+-- mk_eq :: (IsQuantified fof atom v, IsAtomWithEquate atom p term) => term -> term -> fof+-- mk_eq = (.=.)+--+-- dest_eq :: (IsQuantified fof atom v, IsAtomWithEquate 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 :: (IsQuantified fof atom v, IsAtomWithEquate atom p term) => fof -> Failing term+-- lhs eq = dest_eq eq >>= return . fst+-- rhs :: (IsQuantified fof atom v, IsAtomWithEquate atom p term) => fof -> Failing term+-- rhs eq = dest_eq eq >>= return . snd++-- | The set of predicates in a formula.+-- predicates :: (IsQuantified formula atom v, IsAtomWithEquate atom p term, Ord atom, Ord p) => formula -> Set atom+predicates :: IsFormula formula => formula -> Set (AtomOf formula)+predicates fm = atom_union Set.singleton fm++-- | Code to generate equate axioms for functions.+function_congruence :: forall fof atom term v p function.+                       (atom ~ AtomOf fof, term ~ TermOf atom, p ~ PredOf atom, v ~ VarOf fof, v ~ TVarOf term, function ~ FunOf term,+                        IsQuantified fof, HasEquate atom, IsTerm term, Ord fof) =>+                       (function, Int) -> Set fof+function_congruence (_,0) = (∅)+function_congruence (f,n) =+    Set.singleton (List.foldr (∀) (ant ⇒ con) (argnames_x ++ argnames_y))+    where+      argnames_x :: [VarOf fof]+      argnames_x = List.map (\ m -> fromString ("x" ++ show m)) [1..n]+      argnames_y :: [VarOf fof]+      argnames_y = List.map (\ m -> fromString ("y" ++ show m)) [1..n]+      args_x = List.map vt argnames_x+      args_y = List.map vt argnames_y+      ant = foldr1 (∧) (List.map (uncurry (.=.)) (zip args_x args_y))+      con = fApp f args_x .=. fApp f args_y++-- | And for predicates.+predicate_congruence :: (atom ~ AtomOf fof, predicate ~ PredOf atom, term ~ TermOf atom, v ~ VarOf fof, v ~ TVarOf term,+                         IsQuantified fof, HasEquate atom, IsTerm term, Ord predicate) =>+                        AtomOf fof -> Set fof+predicate_congruence =+    foldEquate (\_ _ -> Set.empty) (\p ts -> ap p (length ts))+    where+      ap _ 0 = Set.empty+      ap p n = Set.singleton (List.foldr (∀) (ant ⇒ con) (argnames_x ++ argnames_y))+          where+            argnames_x = List.map (\ m -> fromString ("x" ++ show m)) [1..n]+            argnames_y = List.map (\ m -> fromString ("y" ++ show m)) [1..n]+            args_x = List.map vt argnames_x+            args_y = List.map vt argnames_y+            ant = foldr1 (∧) (List.map (uncurry (.=.)) (zip args_x args_y))+            con = atomic (applyPredicate p args_x) ⇒ atomic (applyPredicate p args_y)++-- | Hence implement logic with equate just by adding equate "axioms".+equivalence_axioms :: forall fof atom term v.+                      (atom ~ AtomOf fof, term ~ TermOf atom, v ~ VarOf fof,+                       IsQuantified fof, HasEquate atom, IsTerm term, Ord fof) => Set fof+equivalence_axioms =+    Set.fromList+    [(∀) "x" (x .=. x),+     (∀) "x" ((∀) "y" ((∀) "z" (x .=. y ∧ x .=. z ⇒ y .=. z)))]+    where+      x :: term+      x = vt (fromString "x")+      y :: term+      y = vt (fromString "y")+      z :: term+      z = vt (fromString "z")++equalitize :: forall formula atom term v function.+              (atom ~ AtomOf formula, term ~ TermOf atom, v ~ VarOf formula, v ~ TVarOf term, function ~ FunOf term,+               IsQuantified formula, HasEquate atom,+               IsTerm term, Ord formula, Ord atom) =>+              formula -> formula+equalitize fm =+    if Set.null eqPreds then fm else foldr1 (∧) axioms ⇒ fm+    where+      axioms = Set.fold (Set.union . function_congruence)+                        (Set.fold (Set.union . predicate_congruence) equivalence_axioms otherPreds)+                        (functions fm)+      (eqPreds, otherPreds) = Set.partition (foldEquate (\_ _ -> True) (\_ _ -> False)) (predicates fm)++-- -------------------------------------------------------------------------+-- Example.+-- -------------------------------------------------------------------------++testEqual01 :: Test+testEqual01 = TestLabel "function_congruence" $ TestCase $ assertEqual "function_congruence" expected input+    where input = List.map function_congruence [(fromString "f", 3 :: Int), (fromString "+",2)]+          expected :: [Set.Set Formula]+          expected = [Set.fromList+                      [(∀) "x1"+                       ((∀) "x2"+                        ((∀) "x3"+                         ((∀) "y1"+                          ((∀) "y2"+                           ((∀) "y3" ((("x1" .=. "y1") ∧ (("x2" .=. "y2") ∧ ("x3" .=. "y3"))) ⇒+                                          ((fApp (fromString "f") ["x1","x2","x3"]) .=. (fApp (fromString "f") ["y1","y2","y3"]))))))))],+                      Set.fromList+                      [(∀) "x1"+                       ((∀) "x2"+                        ((∀) "y1"+                         ((∀) "y2" ((("x1" .=. "y1") ∧ ("x2" .=. "y2")) ⇒+                                        ((fApp (fromString "+") ["x1","x2"]) .=. (fApp (fromString "+") ["y1","y2"]))))))]]++-- -------------------------------------------------------------------------+-- A simple example (see EWD1266a and the application to Morley's theorem).+-- -------------------------------------------------------------------------++ewd :: Formula+ewd = equalitize fm+    where+      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"++testEqual02 :: Test+testEqual02 = TestLabel "equalitize 1 (p. 241)" $ TestCase $ assertEqual "equalitize 1 (p. 241)" (expected, expectedProof) input+    where input = (ewd, runSkolem (meson (Just (Depth 17)) ewd))+          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 =+              ((∀) "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))+          expectedProof =+              Set.fromList [Success (Depth 6)]++-- | Wishnu Prasetya's example (even nicer with an "exists unique" primitive).++--instance IsString ([MyTerm] -> MyTerm) where+--    fromString = fApp . fromString++wishnu :: Formula+wishnu = [fof| (∃x. x=f (g (x))∧(∀x'. x'=f (g (x'))⇒x=x'))⇔(∃y. y=g (f (y))∧(∀y'. y'=g (f (y'))⇒y=y')) |]++-- This takes 0.7 seconds on my machine.+testEqual03 :: Test+testEqual03 =+    (TestLabel "equalitize 2" . TestCase . timeMessage (\_ t -> "\nEqualitize 2 compute time: " ++ show t))+       (assertEqual' "equalitize 2 (p. 241)" (expected, expectedProof) input)+    where input = (equalitize wishnu, runSkolem (meson Nothing (equalitize wishnu)))+          expected :: Formula+          expected = [fof| (∀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 [Success (Depth 16)]++-- -------------------------------------------------------------------------+-- More challenging equational problems. (Size 18, 61814 seconds.)+-- -------------------------------------------------------------------------++{-+(meson ** equalitize)+ <<(forall x y z. x * (y * z) = (x * y) * z) /\+   (forall x. 1 * x = x) /\+   (forall x. i(x) * x = 1)+   ==> forall x. x * i(x) = 1>>;;+-}++testEqual04 :: Test+testEqual04 = TestLabel "equalitize 3 (p. 248)" $ TestCase $+  timeMessage (\_ t -> "\nCompute time: " ++ show t) $+  assertEqual' "equalitize 3 (p. 248)" (expected, expectedProof) input+    where+      input = (equalitize fm, runSkolem (meson (Just (Depth 20)) . equalitize $ fm))+      fm :: Formula+      fm = [fof| (forall x y z. x * (y * z) = (x * y) * z) .&.+                 (forall x. 1 * x = x) .&.+                 (forall x. i(x) * x = 1)+                 ==> (forall x. x * i(x) = 1) |]+{-+      fm = [fof| (∀x y z. ((*) ["x'", (*) ["y'", "z'"]] .=. (*) [((*) ["x'", "y'"]), "z'"]) ∧+           (∀) "x" ((*) [one, "x'"] .=. "x'") ∧+           (∀) "x" ((*) [i ["x'"], "x'"] .=. one) ⇒+           (∀) "x" ((*) ["x'", i ["x'"]] .=. one)+      fm = ((∀) "x" . (∀) "y" . (∀) "z") ((*) ["x'", (*) ["y'", "z'"]] .=. (*) [((*) ["x'", "y'"]), "z'"]) ∧+           (∀) "x" ((*) [one, "x'"] .=. "x'") ∧+           (∀) "x" ((*) [i ["x'"], "x'"] .=. one) ⇒+           (∀) "x" ((*) ["x'", i ["x'"]] .=. one)+      (*) = fApp (fromString "*")+      i = fApp (fromString "i")+      one = fApp (fromString "1") []+-}+      expected :: Formula+      expected =+          [fof| (∀x. x=x)∧+                (∀x y z. x=y∧x=z⇒y=z)∧+                (∀x' x'' y' y''. x'=y'∧x''=y''⇒(x' * x'')=(y' * y''))⇒+                (∀x y z. (x' * (y' * z'))=((x'* y') * z'))∧+                (∀x. (1 * x')=x')∧+                (∀x. (i(x') * x')=1)⇒+                (∀x. (x' * i(x'))=1) |]+{-+          ((∀) "x" ("x" .=. "x") .&.+           ((∀) "x" ((∀) "y" ((∀) "z" ((("x" .=. "y") .&. ("x" .=. "z")) .=>. ("y" .=. "z")))) .&.+            ((∀) "x1" ((∀) "x2" ((∀) "y1" ((∀) "y2" ((("x1" .=. "y1") .&. ("x2" .=. "y2")) .=>.+                                                                     ((fApp "*" ["x1","x2"]) .=. (fApp "*" ["y1","y2"])))))) .&.+             (∀) "x1" ((∀) "y1" (("x1" .=. "y1") .=>. ((fApp "i" ["x1"]) .=. (fApp "i" ["y1"]))))))) .=>.+          ((((∀) "x" ((∀) "y" ((∀) "z" ((fApp "*" ["x",fApp "*" ["y","z"]]) .=. (fApp "*" [fApp "*" ["x","y"],"z"])))) .&.+             (∀) "x" ((fApp "*" [fApp "1" [],"x"]) .=. "x")) .&.+            (∀) "x" ((fApp "*" [fApp "i" ["x"],"x"]) .=. (fApp "1" []))) .=>.+           (∀) "x" ((fApp "*" ["x",fApp "i" ["x"]]) .=. (fApp "1" []))) -}+      expectedProof :: Set.Set (Failing Depth)+      expectedProof = Set.fromList [Failure ["Exceeded maximum depth limit"]]++testEqual :: Test+testEqual = TestLabel "Equal" (TestList [testEqual01, testEqual02, testEqual03 {-, testEqual04-}])++-- -------------------------------------------------------------------------+-- Other variants not mentioned in book.+-- -------------------------------------------------------------------------++{-+{- ************++(meson ** equalitize)+ <<(forall x y z. x * (y * z) = (x * y) * z) /\+   (forall x. 1 * x = x) /\+   (forall x. x * 1 = x) /\+   (forall x. x * x = 1)+   ==> forall x y. x * y  = y * x>>;;++-- -------------------------------------------------------------------------+-- With symmetry at leaves and one-sided congruences (Size = 16, 54659 s).+-- -------------------------------------------------------------------------++let fm =+ <<(forall x. x = x) /\+   (forall x y z. x * (y * z) = (x * y) * z) /\+   (forall x y z. =((x * y) * z,x * (y * z))) /\+   (forall x. 1 * x = x) /\+   (forall x. x = 1 * x) /\+   (forall x. i(x) * x = 1) /\+   (forall x. 1 = i(x) * x) /\+   (forall x y. x = y ==> i(x) = i(y)) /\+   (forall x y z. x = y ==> x * z = y * z) /\+   (forall x y z. x = y ==> z * x = z * y) /\+   (forall x y z. x = y /\ y = z ==> x = z)+   ==> forall x. x * i(x) = 1>>;;++time meson fm;;++-- -------------------------------------------------------------------------+-- Newer version of stratified equalities.+-- -------------------------------------------------------------------------++let fm =+ <<(forall x y z. axiom(x * (y * z),(x * y) * z)) /\+   (forall x y z. axiom((x * y) * z,x * (y * z)) /\+   (forall x. axiom(1 * x,x)) /\+   (forall x. axiom(x,1 * x)) /\+   (forall x. axiom(i(x) * x,1)) /\+   (forall x. axiom(1,i(x) * x)) /\+   (forall x x'. x = x' ==> cchain(i(x),i(x'))) /\+   (forall x x' y y'. x = x' /\ y = y' ==> cchain(x * y,x' * y'))) /\+   (forall s t. axiom(s,t) ==> achain(s,t)) /\+   (forall s t u. axiom(s,t) /\ (t = u) ==> achain(s,u)) /\+   (forall x x' u. x = x' /\ achain(i(x'),u) ==> cchain(i(x),u)) /\+   (forall x x' y y' u.+        x = x' /\ y = y' /\ achain(x' * y',u) ==> cchain(x * y,u)) /\+   (forall s t. cchain(s,t) ==> s = t) /\+   (forall s t. achain(s,t) ==> s = t) /\+   (forall t. t = t)+   ==> forall x. x * i(x) = 1>>;;++time meson fm;;++let fm =+ <<(forall x y z. axiom(x * (y * z),(x * y) * z)) /\+   (forall x y z. axiom((x * y) * z,x * (y * z)) /\+   (forall x. axiom(1 * x,x)) /\+   (forall x. axiom(x,1 * x)) /\+   (forall x. axiom(i(x) * x,1)) /\+   (forall x. axiom(1,i(x) * x)) /\+   (forall x x'. x = x' ==> cong(i(x),i(x'))) /\+   (forall x x' y y'. x = x' /\ y = y' ==> cong(x * y,x' * y'))) /\+   (forall s t. axiom(s,t) ==> achain(s,t)) /\+   (forall s t. cong(s,t) ==> cchain(s,t)) /\+   (forall s t u. axiom(s,t) /\ (t = u) ==> achain(s,u)) /\+   (forall s t u. cong(s,t) /\ achain(t,u) ==> cchain(s,u)) /\+   (forall s t. cchain(s,t) ==> s = t) /\+   (forall s t. achain(s,t) ==> s = t) /\+   (forall t. t = t)+   ==> forall x. x * i(x) = 1>>;;++time meson fm;;++-- -------------------------------------------------------------------------+-- Showing congruence closure.+-- -------------------------------------------------------------------------++let fm = equalitize+ <<forall c. f(f(f(f(f(c))))) = c /\ f(f(f(c))) = c ==> f(c) = c>>;;++time meson fm;;++let fm =+ <<axiom(f(f(f(f(f(c))))),c) /\+   axiom(c,f(f(f(f(f(c)))))) /\+   axiom(f(f(f(c))),c) /\+   axiom(c,f(f(f(c)))) /\+   (forall s t. axiom(s,t) ==> achain(s,t)) /\+   (forall s t. cong(s,t) ==> cchain(s,t)) /\+   (forall s t u. axiom(s,t) /\ (t = u) ==> achain(s,u)) /\+   (forall s t u. cong(s,t) /\ achain(t,u) ==> cchain(s,u)) /\+   (forall s t. cchain(s,t) ==> s = t) /\+   (forall s t. achain(s,t) ==> s = t) /\+   (forall t. t = t) /\+   (forall x y. x = y ==> cong(f(x),f(y)))+   ==> f(c) = c>>;;++time meson fm;;++-- -------------------------------------------------------------------------+-- With stratified equalities.+-- -------------------------------------------------------------------------++let fm =+ <<(forall x y z. eqA (x * (y * z),(x * y) * z)) /\+   (forall x y z. eqA ((x * y) * z)) /\+   (forall x. eqA (1 * x,x)) /\+   (forall x. eqA (x,1 * x)) /\+   (forall x. eqA (i(x) * x,1)) /\+   (forall x. eqA (1,i(x) * x)) /\+   (forall x. eqA (x,x)) /\+   (forall x y. eqA (x,y) ==> eqC (i(x),i(y))) /\+   (forall x y. eqC (x,y) ==> eqC (i(x),i(y))) /\+   (forall x y. eqT (x,y) ==> eqC (i(x),i(y))) /\+   (forall w x y z. eqA (w,x) /\ eqA (y,z) ==> eqC (w * y,x * z)) /\+   (forall w x y z. eqA (w,x) /\ eqC (y,z) ==> eqC (w * y,x * z)) /\+   (forall w x y z. eqA (w,x) /\ eqT (y,z) ==> eqC (w * y,x * z)) /\+   (forall w x y z. eqC (w,x) /\ eqA (y,z) ==> eqC (w * y,x * z)) /\+   (forall w x y z. eqC (w,x) /\ eqC (y,z) ==> eqC (w * y,x * z)) /\+   (forall w x y z. eqC (w,x) /\ eqT (y,z) ==> eqC (w * y,x * z)) /\+   (forall w x y z. eqT (w,x) /\ eqA (y,z) ==> eqC (w * y,x * z)) /\+   (forall w x y z. eqT (w,x) /\ eqC (y,z) ==> eqC (w * y,x * z)) /\+   (forall w x y z. eqT (w,x) /\ eqT (y,z) ==> eqC (w * y,x * z)) /\+   (forall x y z. eqA (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\+   (forall x y z. eqC (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\+   (forall x y z. eqA (x,y) /\ eqC (y,z) ==> eqT (x,z)) /\+   (forall x y z. eqA (x,y) /\ eqT (y,z) ==> eqT (x,z)) /\+   (forall x y z. eqC (x,y) /\ eqT (y,z) ==> eqT (x,z))+   ==> forall x. eqT (x * i(x),1)>>;;++-- -------------------------------------------------------------------------+-- With transitivity chains...+-- -------------------------------------------------------------------------++let fm =+ <<(forall x y z. eqA (x * (y * z),(x * y) * z)) /\+   (forall x y z. eqA ((x * y) * z)) /\+   (forall x. eqA (1 * x,x)) /\+   (forall x. eqA (x,1 * x)) /\+   (forall x. eqA (i(x) * x,1)) /\+   (forall x. eqA (1,i(x) * x)) /\+   (forall x y. eqA (x,y) ==> eqC (i(x),i(y))) /\+   (forall x y. eqC (x,y) ==> eqC (i(x),i(y))) /\+   (forall w x y. eqA (w,x) ==> eqC (w * y,x * y)) /\+   (forall w x y. eqC (w,x) ==> eqC (w * y,x * y)) /\+   (forall x y z. eqA (y,z) ==> eqC (x * y,x * z)) /\+   (forall x y z. eqC (y,z) ==> eqC (x * y,x * z)) /\+   (forall x y z. eqA (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\+   (forall x y z. eqC (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\+   (forall x y z. eqA (x,y) /\ eqC (y,z) ==> eqT (x,z)) /\+   (forall x y z. eqC (x,y) /\ eqC (y,z) ==> eqT (x,z)) /\+   (forall x y z. eqA (x,y) /\ eqT (y,z) ==> eqT (x,z)) /\+   (forall x y z. eqC (x,y) /\ eqT (y,z) ==> eqT (x,z))+   ==> forall x. eqT (x * i(x),1) \/ eqC (x * i(x),1)>>;;++time meson fm;;++-- -------------------------------------------------------------------------+-- Enforce canonicity (proof size = 20).+-- -------------------------------------------------------------------------++let fm =+ <<(forall x y z. eq1(x * (y * z),(x * y) * z)) /\+   (forall x y z. eq1((x * y) * z,x * (y * z))) /\+   (forall x. eq1(1 * x,x)) /\+   (forall x. eq1(x,1 * x)) /\+   (forall x. eq1(i(x) * x,1)) /\+   (forall x. eq1(1,i(x) * x)) /\+   (forall x y z. eq1(x,y) ==> eq1(x * z,y * z)) /\+   (forall x y z. eq1(x,y) ==> eq1(z * x,z * y)) /\+   (forall x y z. eq1(x,y) /\ eq2(y,z) ==> eq2(x,z)) /\+   (forall x y. eq1(x,y) ==> eq2(x,y))+   ==> forall x. eq2(x,i(x))>>;;++time meson fm;;++***************** -}+END_INTERACTIVE;;+-}
+ src/Data/Logic/ATP/Equate.hs view
@@ -0,0 +1,131 @@+-- | ATOM with the Equate predicate++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Logic.ATP.Equate+    ( HasEquate(equate, foldEquate)+    , (.=.)+    , zipEquates+    , isEquate+    , prettyEquate+    , overtermsEq+    , ontermsEq+    , showApplyAndEquate+    , showEquate+    , convertEquate+    , precedenceEquate+    , associativityEquate+    , FOL(R, Equals)+    , EqAtom+    ) where++import Data.Data (Data)+import Data.Logic.ATP.Apply (HasApply(PredOf, TermOf, applyPredicate, foldApply', overterms, onterms),+                             IsPredicate, Predicate, prettyApply, showApply)+import Data.Logic.ATP.Formulas (IsAtom, IsFormula(..))+import Data.Logic.ATP.Pretty as Pretty ((<>), Associativity(InfixN), atomPrec, Doc, eqPrec, HasFixity(associativity, precedence), pAppPrec, Precedence, text)+import Data.Logic.ATP.Term (FTerm, IsTerm)+import Data.Typeable (Typeable)+import Prelude hiding (pred)+import Text.PrettyPrint.HughesPJClass (maybeParens, Pretty(pPrintPrec), PrettyLevel)++-- | Atoms that support equality must have HasEquate instance+class HasApply atom => HasEquate atom where+    equate :: TermOf atom -> TermOf atom -> atom+    foldEquate :: (TermOf atom -> TermOf atom -> r) -> (PredOf atom -> [TermOf atom] -> r) -> atom -> r++-- | Build an equality formula from two terms.+(.=.) :: (IsFormula formula, HasEquate atom, atom ~ AtomOf formula) => TermOf atom -> TermOf atom -> formula+a .=. b = atomic (equate a b)+infix 6 .=.++-- | Zip two atoms that support equality+zipEquates :: HasEquate atom =>+              (TermOf atom -> TermOf atom ->+               TermOf atom -> TermOf atom -> Maybe r)+           -> (PredOf atom -> [(TermOf atom, TermOf atom)] -> Maybe r)+           -> atom -> atom -> Maybe r+zipEquates eq ap atom1 atom2 =+    foldEquate eq' ap' atom1+    where+      eq' l1 r1 = foldEquate (eq l1 r1) (\_ _ -> Nothing) atom2+      ap' p1 ts1 = foldEquate (\_ _ -> Nothing) (ap'' p1 ts1) atom2+      ap'' p1 ts1 p2 ts2 | p1 == p2 && length ts1 == length ts2 = ap p1 (zip ts1 ts2)+      ap'' _ _ _ _ = Nothing++isEquate :: HasEquate atom => atom -> Bool+isEquate = foldEquate (\_ _ -> True) (\_ _ -> False)++-- | Format the infix equality predicate applied to two terms.+prettyEquate :: IsTerm term => PrettyLevel -> Rational -> term -> term -> Doc+prettyEquate l p t1 t2 =+    maybeParens (p > atomPrec) $ pPrintPrec l atomPrec t1 <> text "=" <> pPrintPrec l atomPrec t2++-- | Implementation of 'overterms' for 'HasApply' types.+overtermsEq :: HasEquate atom => ((TermOf atom) -> r -> r) -> r -> atom -> r+overtermsEq f r0 = foldEquate (\t1 t2 -> f t2 (f t1 r0)) (\_ ts -> foldr f r0 ts)++-- | Implementation of 'onterms' for 'HasApply' types.+ontermsEq :: HasEquate atom => ((TermOf atom) -> (TermOf atom)) -> atom -> atom+ontermsEq f = foldEquate (\t1 t2 -> equate (f t1) (f t2)) (\p ts -> applyPredicate p (map f ts))++-- | Implementation of Show for HasEquate types+showApplyAndEquate :: (HasEquate atom, Show (TermOf atom)) => atom -> String+showApplyAndEquate atom = foldEquate showEquate showApply atom++showEquate :: Show term => term -> term -> String+showEquate t1 t2 = "(" ++ show t1 ++ ") .=. (" ++ show t2 ++ ")"++convertEquate :: (HasEquate atom1, HasEquate atom2) =>+                 (PredOf atom1 -> PredOf atom2) -> (TermOf atom1 -> TermOf atom2) -> atom1 -> atom2+convertEquate cp ct = foldEquate (\t1 t2 -> equate (ct t1) (ct t2)) (\p1 ts1 -> applyPredicate (cp p1) (map ct ts1))++precedenceEquate :: HasEquate atom => atom -> Precedence+precedenceEquate = foldEquate (\_ _ -> eqPrec) (\_ _ -> pAppPrec)++associativityEquate :: HasEquate atom => atom -> Associativity+associativityEquate = foldEquate (\_ _ -> Pretty.InfixN) (\_ _ -> Pretty.InfixN)++-- | Instance of an atom type with a distinct equality predicate.+data FOL predicate term = R predicate [term] | Equals term term deriving (Eq, Ord, Data, Typeable, Read)++instance (IsPredicate predicate, IsTerm term) => HasEquate (FOL predicate term) where+    equate lhs rhs = Equals lhs rhs+    foldEquate eq _ (Equals lhs rhs) = eq lhs rhs+    foldEquate _ ap (R p ts) = ap p ts++instance (IsPredicate predicate, IsTerm term) => IsAtom (FOL predicate term)++instance (HasApply (FOL predicate term),+          HasEquate (FOL predicate term), IsTerm term) => Pretty (FOL predicate term) where+    pPrintPrec d r = foldEquate (prettyEquate d r) prettyApply++instance (IsPredicate predicate, IsTerm term) => HasApply (FOL predicate term) where+    type PredOf (FOL predicate term) = predicate+    type TermOf (FOL predicate term) = term+    applyPredicate = R+    foldApply' _ f (R p ts) = f p ts+    foldApply' d _ x = d x+    overterms = overtermsEq+    onterms = ontermsEq++instance (IsPredicate predicate, IsTerm term, Show predicate, Show term) => Show (FOL predicate term) where+    show = foldEquate (\t1 t2 -> showEquate (t1 :: term) (t2 :: term))+                      (\p ts -> showApply (p :: predicate) (ts :: [term]))++instance  (IsPredicate predicate, IsTerm term) => HasFixity (FOL predicate term) where+    precedence = precedenceEquate+    associativity = associativityEquate++-- | An atom type with equality predicate+type EqAtom = FOL Predicate FTerm
+ src/Data/Logic/ATP/FOL.hs view
@@ -0,0 +1,447 @@+-- | Basic stuff for first order logic.+--+-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Logic.ATP.FOL+    ( IsFirstOrder+    -- * Semantics+    , Interp+    , holds+    , holdsQuantified+    , holdsAtom+    , termval+    -- * Free Variables+    , var+    , fv, fva, fvt+    , generalize+    -- * Substitution+    , subst, substq, asubst, tsubst, lsubst+    , bool_interp+    , mod_interp+    -- * Concrete instances of formula types for use in unit tests.+    , ApFormula, EqFormula+    -- * Tests+    , testFOL+    ) where++import Data.Logic.ATP.Apply (ApAtom, HasApply(PredOf, TermOf, overterms, onterms), Predicate)+import Data.Logic.ATP.Equate ((.=.), EqAtom, foldEquate, HasEquate)+import Data.Logic.ATP.Formulas (fromBool, IsFormula(..))+import Data.Logic.ATP.Lib (setAny, tryApplyD, undefine, (|->))+import Data.Logic.ATP.Lit ((.~.), foldLiteral, JustLiteral)+import Data.Logic.ATP.Pretty (prettyShow)+import Data.Logic.ATP.Prop (BinOp(..), IsPropositional((.&.), (.|.), (.=>.), (.<=>.)))+import Data.Logic.ATP.Quantified (exists, foldQuantified, for_all, IsQuantified(VarOf), Quant((:!:), (:?:)), QFormula)+import Data.Logic.ATP.Term (FName, foldTerm, IsTerm(FunOf, TVarOf, vt, fApp), V, variant)+import Data.Map.Strict as Map (empty, fromList, insert, lookup, Map)+import Data.Maybe (fromMaybe)+import Data.Set as Set (difference, empty, fold, fromList, member, Set, singleton, union, unions)+import Data.String (IsString(fromString))+import Prelude hiding (pred)+import Test.HUnit++-- | Combine IsQuantified, HasApply, IsTerm, and make sure the term is+-- using the same variable type as the formula.+class (IsQuantified formula,+       HasApply (AtomOf formula),+       IsTerm (TermOf (AtomOf formula)),+       VarOf formula ~ TVarOf (TermOf (AtomOf formula)))+    => IsFirstOrder formula++-- | A formula type with no equality predicate+type ApFormula = QFormula V ApAtom+instance IsFirstOrder ApFormula++-- | A formula type with equality predicate+type EqFormula = QFormula V EqAtom+instance IsFirstOrder EqFormula++{-+(* Trivial example of "x + y < z".                                           *)+(* ------------------------------------------------------------------------- *)++START_INTERACTIVE;;+Atom(R("<",[Fn("+",[Var "x"; Var "y"]); Var "z"]));;+END_INTERACTIVE;;++(* ------------------------------------------------------------------------- *)+(* Parsing of terms.                                                         *)+(* ------------------------------------------------------------------------- *)++let is_const_name s = forall numeric (explode s) or s = "nil";;++let rec parse_atomic_term vs inp =+  match inp with+    [] -> failwith "term expected"+  | "("::rest -> parse_bracketed (parse_term vs) ")" rest+  | "-"::rest -> papply (fun t -> Fn("-",[t])) (parse_atomic_term vs rest)+  | f::"("::")"::rest -> Fn(f,[]),rest+  | f::"("::rest ->+      papply (fun args -> Fn(f,args))+             (parse_bracketed (parse_list "," (parse_term vs)) ")" rest)+  | a::rest ->+      (if is_const_name a & not(mem a vs) then Fn(a,[]) else Var a),rest++and parse_term vs inp =+  parse_right_infix "::" (fun (e1,e2) -> Fn("::",[e1;e2]))+    (parse_right_infix "+" (fun (e1,e2) -> Fn("+",[e1;e2]))+       (parse_left_infix "-" (fun (e1,e2) -> Fn("-",[e1;e2]))+          (parse_right_infix "*" (fun (e1,e2) -> Fn("*",[e1;e2]))+             (parse_left_infix "/" (fun (e1,e2) -> Fn("/",[e1;e2]))+                (parse_left_infix "^" (fun (e1,e2) -> Fn("^",[e1;e2]))+                   (parse_atomic_term vs)))))) inp;;++let parset = make_parser (parse_term []);;++(* ------------------------------------------------------------------------- *)+(* Parsing of formulas.                                                      *)+(* ------------------------------------------------------------------------- *)++let parse_infix_atom vs inp =+  let tm,rest = parse_term vs inp in+  if exists (nextin rest) ["="; "<"; "<="; ">"; ">="] then+        papply (fun tm' -> Atom(R(hd rest,[tm;tm'])))+               (parse_term vs (tl rest))+  else failwith "";;++let parse_atom vs inp =+  try parse_infix_atom vs inp with Failure _ ->+  match inp with+  | p::"("::")"::rest -> Atom(R(p,[])),rest+  | p::"("::rest ->+      papply (fun args -> Atom(R(p,args)))+             (parse_bracketed (parse_list "," (parse_term vs)) ")" rest)+  | p::rest when p <> "(" -> Atom(R(p,[])),rest+  | _ -> failwith "parse_atom";;++let parse = make_parser+  (parse_formula (parse_infix_atom,parse_atom) []);;++(* ------------------------------------------------------------------------- *)+(* Set up parsing of quotations.                                             *)+(* ------------------------------------------------------------------------- *)++let default_parser = parse;;++let secondary_parser = parset;;++{-+(* ------------------------------------------------------------------------- *)+(* Example.                                                                  *)+(* ------------------------------------------------------------------------- *)++START_INTERACTIVE;;+<<(forall x. x < 2 ==> 2 * x <= 3) \/ false>>;;++<<|2 * x|>>;;+END_INTERACTIVE;;+-}++(* ------------------------------------------------------------------------- *)+(* Printing of terms.                                                        *)+(* ------------------------------------------------------------------------- *)++let rec print_term prec fm =+  match fm with+    Var x -> print_string x+  | Fn("^",[tm1;tm2]) -> print_infix_term true prec 24 "^" tm1 tm2+  | Fn("/",[tm1;tm2]) -> print_infix_term true prec 22 " /" tm1 tm2+  | Fn("*",[tm1;tm2]) -> print_infix_term false prec 20 " *" tm1 tm2+  | Fn("-",[tm1;tm2]) -> print_infix_term true prec 18 " -" tm1 tm2+  | Fn("+",[tm1;tm2]) -> print_infix_term false prec 16 " +" tm1 tm2+  | Fn("::",[tm1;tm2]) -> print_infix_term false prec 14 "::" tm1 tm2+  | Fn(f,args) -> print_fargs f args++and print_fargs f args =+  print_string f;+  if args = [] then () else+   (print_string "(";+    open_box 0;+    print_term 0 (hd args); print_break 0 0;+    do_list (fun t -> print_string ","; print_break 0 0; print_term 0 t)+            (tl args);+    close_box();+    print_string ")")++and print_infix_term isleft oldprec newprec sym p q =+  if oldprec > newprec then (print_string "("; open_box 0) else ();+  print_term (if isleft then newprec else newprec+1) p;+  print_string sym;+  print_break (if String.sub sym 0 1 = " " then 1 else 0) 0;+  print_term (if isleft then newprec+1 else newprec) q;+  if oldprec > newprec then (close_box(); print_string ")") else ();;++let printert tm =+  open_box 0; print_string "<<|";+  open_box 0; print_term 0 tm; close_box();+  print_string "|>>"; close_box();;++#install_printer printert;;++(* ------------------------------------------------------------------------- *)+(* Printing of formulas.                                                     *)+(* ------------------------------------------------------------------------- *)++let print_atom prec (R(p,args)) =+  if mem p ["="; "<"; "<="; ">"; ">="] & length args = 2+  then print_infix_term false 12 12 (" "^p) (el 0 args) (el 1 args)+  else print_fargs p args;;++let print_fol_formula = print_qformula print_atom;;++#install_printer print_fol_formula;;++(* ------------------------------------------------------------------------- *)+(* Examples in the main text.                                                *)+(* ------------------------------------------------------------------------- *)++START_INTERACTIVE;;+<<forall x y. exists z. x < z /\ y < z>>;;++<<~(forall x. P(x)) <=> exists y. ~P(y)>>;;+END_INTERACTIVE;;+-}++-- | Specify the domain of a formula interpretation, and how to+-- interpret its functions and predicates.+data Interp function predicate d+    = Interp { domain :: [d]+             , funcApply :: function -> [d] -> d+             , predApply :: predicate -> [d] -> Bool+             , eqApply :: d -> d -> Bool }++-- | The holds function computes the value of a formula for a finite domain.+class FiniteInterpretation a function predicate v dom where+    holds :: Interp function predicate dom -> Map v dom -> a -> Bool++-- | Implementation of holds for IsQuantified formulas.+holdsQuantified :: forall formula function predicate dom.+                   (IsQuantified formula,+                    FiniteInterpretation (AtomOf formula) function predicate (VarOf formula) dom,+                    FiniteInterpretation formula function predicate (VarOf formula) dom) =>+                   Interp function predicate dom -> Map (VarOf formula) dom -> formula -> Bool+holdsQuantified m v fm =+    foldQuantified qu co ne tf at fm+    where+      qu (:!:) x p = and (map (\a -> holds m (Map.insert x a v) p) (domain m)) -- >>= return . any (== True)+      qu (:?:) x p = or (map (\a -> holds m (Map.insert x a v) p) (domain m)) -- return . all (== True)?+      ne p = not (holds m v p)+      co p (:&:) q = (holds m v p) && (holds m v q)+      co p (:|:) q = (holds m v p) || (holds m v q)+      co p (:=>:) q = not (holds m v p) || (holds m v q)+      co p (:<=>:) q = (holds m v p) == (holds m v q)+      tf x = x+      at = (holds m v :: AtomOf formula -> Bool)++-- | Implementation of holds for atoms with equate predicates.+holdsAtom :: (HasEquate atom, IsTerm term, Eq dom,+              term ~ TermOf atom, v ~ TVarOf term, function ~ FunOf term, predicate ~ PredOf atom) =>+             Interp function predicate dom -> Map v dom -> atom -> Bool+holdsAtom m v at = foldEquate (\t1 t2 -> eqApply m (termval m v t1) (termval m v t2))+                                (\r args -> predApply m r (map (termval m v) args)) at++termval :: (IsTerm term, v ~ TVarOf term, function ~ FunOf term) => Interp function predicate r -> Map v r -> term -> r+termval m v tm =+    foldTerm (\x -> fromMaybe (error ("Undefined variable: " ++ show x)) (Map.lookup x v))+             (\f args -> funcApply m f (map (termval m v) args)) tm++{-+START_INTERACTIVE;;+holds bool_interp undefined <<forall x. (x = 0) \/ (x = 1)>>;;++holds (mod_interp 2) undefined <<forall x. (x = 0) \/ (x = 1)>>;;++holds (mod_interp 3) undefined <<forall x. (x = 0) \/ (x = 1)>>;;++let fm = <<forall x. ~(x = 0) ==> exists y. x * y = 1>>;;++filter (fun n -> holds (mod_interp n) undefined fm) (1--45);;++holds (mod_interp 3) undefined <<(forall x. x = 0) ==> 1 = 0>>;;+holds (mod_interp 3) undefined <<forall x. x = 0 ==> 1 = 0>>;;+END_INTERACTIVE;;+-}++-- | Examples of particular interpretations.+bool_interp :: Interp FName Predicate Bool+bool_interp =+    Interp [False, True] func pred (==)+    where+      func f [] | f == fromString "False" = False+      func f [] | f == fromString "True" = True+      func f [x,y] | f == fromString "+" = x /= y+      func f [x,y] | f == fromString "*" = x && y+      func f _ = error ("bool_interp - uninterpreted function: " ++ show f)+      pred p _ = error ("bool_interp - uninterpreted predicate: " ++ show p)++mod_interp :: Int -> Interp FName Predicate Int+mod_interp n =+    Interp [0..(n-1)] func pred (==)+    where+      func f [] | f == fromString "0" = 0+      func f [] | f == fromString "1" = 1 `mod` n+      func f [x,y] | f == fromString "+" = (x + y) `mod` n+      func f [x,y] | f == fromString "*" = (x * y) `mod` n+      func f _ = error ("mod_interp - uninterpreted function: " ++ show f)+      pred p _ = error ("mod_interp - uninterpreted predicate: " ++ show p)++instance Eq dom => FiniteInterpretation EqFormula FName Predicate V dom where holds = holdsQuantified+instance Eq dom => FiniteInterpretation EqAtom FName Predicate V dom where holds = holdsAtom++test01 :: Test+test01 = TestCase $ assertEqual "holds bool test (p. 126)" expected input+    where input = holds bool_interp (Map.empty :: Map V Bool) (for_all "x" ((vt "x") .=. (fApp "False" []) .|. (vt "x") .=. (fApp "True" [])) :: EqFormula)+          expected = True+test02 :: Test+test02 = TestCase $ assertEqual "holds mod test 1 (p. 126)" expected input+    where input =  holds (mod_interp 2) (Map.empty :: Map V Int) (for_all "x" (vt "x" .=. (fApp "0" []) .|. vt "x" .=. (fApp "1" [])) :: EqFormula)+          expected = True+test03 :: Test+test03 = TestCase $ assertEqual "holds mod test 2 (p. 126)" expected input+    where input =  holds (mod_interp 3) (Map.empty :: Map V Int) (for_all "x" (vt "x" .=. fApp "0" [] .|. vt "x" .=. fApp "1" []) :: EqFormula)+          expected = False++test04 :: Test+test04 = TestCase $ assertEqual "holds mod test 3 (p. 126)" expected input+    where input = filter (\ n -> holds (mod_interp n) (Map.empty :: Map V Int) fm) [1..45]+                  where fm = for_all "x" ((.~.) (vt "x" .=. fApp "0" []) .=>. exists "y" (fApp "*" [vt "x", vt "y"] .=. fApp "1" [])) :: EqFormula+          expected = [1,2,3,5,7,11,13,17,19,23,29,31,37,41,43]++test05 :: Test+test05 = TestCase $ assertEqual "holds mod test 4 (p. 129)" expected input+    where input = holds (mod_interp 3) (Map.empty :: Map V Int) ((for_all "x" (vt "x" .=. fApp "0" [])) .=>. fApp "1" [] .=. fApp "0" [] :: EqFormula)+          expected = True+test06 :: Test+test06 = TestCase $ assertEqual "holds mod test 5 (p. 129)" expected input+    where input = holds (mod_interp 3) (Map.empty :: Map V Int) (for_all "x" (vt "x" .=. fApp "0" [] .=>. fApp "1" [] .=. fApp "0" []) :: EqFormula)+          expected = False++-- Free variables in terms and formulas.++-- | Find the free variables in a formula.+fv :: (IsFirstOrder formula, v ~ VarOf formula) => formula -> Set v+fv fm =+    foldQuantified qu co ne tf at fm+    where+      qu _ x p = difference (fv p) (singleton x)+      ne p = fv p+      co p _ q = union (fv p) (fv q)+      tf _ = Set.empty+      at = fva++-- | Find all the variables in a formula.+-- var :: (IsFirstOrder formula, v ~ VarOf formula) => formula -> Set v+var :: (IsFormula formula, HasApply atom,+        atom ~ AtomOf formula, term ~ TermOf atom, v ~ TVarOf term) =>+       formula -> Set v+var fm = overatoms (\a s -> Set.union (fva a) s) fm mempty++-- | Find the variables in an atom+fva :: (HasApply atom, IsTerm term, term ~ TermOf atom, v ~ TVarOf term) => atom -> Set v+fva = overterms (\t s -> Set.union (fvt t) s) mempty++-- | Find the variables in a term+fvt :: (IsTerm term, v ~ TVarOf term) => term -> Set v+fvt tm = foldTerm singleton (\_ args -> unions (map fvt args)) tm++-- | Universal closure of a formula.+generalize :: IsFirstOrder formula => formula -> formula+generalize fm = Set.fold for_all fm (fv fm)++test07 :: Test+test07 = TestCase $ assertEqual "variant 1 (p. 133)" expected input+    where input = variant "x" (Set.fromList ["y", "z"]) :: V+          expected = "x"+test08 :: Test+test08 = TestCase $ assertEqual "variant 2 (p. 133)" expected input+    where input = variant "x" (Set.fromList ["x", "y"]) :: V+          expected = "x'"+test09 :: Test+test09 = TestCase $ assertEqual "variant 3 (p. 133)" expected input+    where input = variant "x" (Set.fromList ["x", "x'"]) :: V+          expected = "x''"++-- | Substitution in formulas, with variable renaming.+subst :: (IsFirstOrder formula, term ~ TermOf (AtomOf formula), v ~ VarOf formula) => Map v term -> formula -> formula+subst subfn fm =+    foldQuantified qu co ne tf at fm+    where+      qu (:!:) x p = substq subfn for_all x p+      qu (:?:) x p = substq subfn exists x p+      ne p = (.~.) (subst subfn p)+      co p (:&:) q = (subst subfn p) .&. (subst subfn q)+      co p (:|:) q = (subst subfn p) .|. (subst subfn q)+      co p (:=>:) q = (subst subfn p) .=>. (subst subfn q)+      co p (:<=>:) q = (subst subfn p) .<=>. (subst subfn q)+      tf False = false+      tf True = true+      at = atomic . asubst subfn++-- | Substitution within terms.+tsubst :: (IsTerm term, v ~ TVarOf term) => Map v term -> term -> term+tsubst sfn tm =+    foldTerm (\x -> fromMaybe tm (Map.lookup x sfn))+             (\f args -> fApp f (map (tsubst sfn) args))+             tm++-- | Substitution within a Literal+lsubst :: (JustLiteral lit, HasApply atom, IsTerm term,+           atom ~ AtomOf lit,+           term ~ TermOf atom,+           v ~ TVarOf term) =>+          Map v term -> lit -> lit+lsubst subfn fm =+    foldLiteral ne fromBool at fm+    where+      ne p = (.~.) (lsubst subfn p)+      at = atomic . asubst subfn++-- | Substitution within atoms.+asubst :: (HasApply atom, IsTerm term, term ~ TermOf atom, v ~ TVarOf term) => Map v term -> atom -> atom+asubst sfn a = onterms (tsubst sfn) a++-- | Substitution within quantifiers+substq :: (IsFirstOrder formula, v ~ VarOf formula, term ~ TermOf (AtomOf formula)) =>+          Map v term -> (v -> formula -> formula) -> v -> formula -> formula+substq subfn qu x p =+  let x' = if setAny (\y -> Set.member x (fvt(tryApplyD subfn y (vt y))))+                     (difference (fv p) (singleton x))+           then variant x (fv (subst (undefine x subfn) p)) else x in+  qu x' (subst ((x |-> vt x') subfn) p)++-- Examples.++test10 :: Test+test10 =+    let [x, x', y] = [vt "x", vt "x'", vt "y"]+        fm = for_all "x" ((x .=. y)) :: EqFormula+        expected = for_all "x'" (x' .=. x) :: EqFormula in+    TestCase $ assertEqual ("subst (\"y\" |=> Var \"x\") " ++ prettyShow fm ++ " (p. 134)")+                           expected+                           (subst (Map.fromList [("y", x)]) fm)++test11 :: Test+test11 =+    let [x, x', x'', y] = [vt "x", vt "x'", vt "x''", vt "y"]+        fm = (for_all "x" (for_all "x'" ((x .=. y) .=>. (x .=. x')))) :: EqFormula+        expected = for_all "x'" (for_all "x''" ((x' .=. x) .=>. ((x' .=. x'')))) :: EqFormula in+    TestCase $ assertEqual ("subst (\"y\" |=> Var \"x\") " ++ prettyShow fm ++ " (p. 134)")+                           expected+                           (subst (Map.fromList [("y", x)]) fm)++testFOL :: Test+testFOL = TestLabel "FOL" (TestList [test01, test02, test03, test04,+                                     test05, test06, test07, test08, test09,+                                     test10, test11])
+ src/Data/Logic/ATP/Formulas.hs view
@@ -0,0 +1,63 @@+-- | The 'IsFormula' class contains definitions for the boolean true+-- and false values, and methods for traversing the atoms of a formula.++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Logic.ATP.Formulas+    ( IsAtom+    , IsFormula(AtomOf, true, false, asBool, atomic, overatoms, onatoms)+    , (⊥), (⊤)+    , fromBool+    , prettyBool+    , atom_union+    ) where++import Data.Logic.ATP.Pretty (Doc, HasFixity, Pretty, text)+import Data.Set as Set (Set, empty, union)+import Prelude hiding (negate)++-- | Basic properties of an atomic formula+class (Ord atom, Show atom, HasFixity atom, Pretty atom) => IsAtom atom++-- | Class associating a formula type with its atom (atomic formula) type.+class (Pretty formula, HasFixity formula, IsAtom (AtomOf formula)) => IsFormula formula where+    type AtomOf formula+    -- ^ AtomOf is a function that maps the formula type to the+    -- associated atomic formula type+    true :: formula+    -- ^ The true element+    false :: formula+    -- ^ The false element+    asBool :: formula -> Maybe Bool+    -- ^ If the arugment is true or false return the corresponding+    -- 'Bool', otherwise return 'Nothing'.+    atomic :: AtomOf formula -> formula+    -- ^ Build a formula from an atom.+    overatoms :: (AtomOf formula -> r -> r) -> formula -> r -> r+    -- ^ Formula analog of iterator 'foldr'.+    onatoms :: (AtomOf formula -> AtomOf formula) -> formula -> formula+    -- ^ Apply a function to the atoms, otherwise keeping structure (new sig)++(⊤) :: IsFormula p => p+(⊤) = true++(⊥) :: IsFormula p => p+(⊥) = false++fromBool :: IsFormula formula => Bool -> formula+fromBool True = true+fromBool False = false++prettyBool :: Bool -> Doc+prettyBool True = text "⊤"+prettyBool False = text "⊥"++-- | Special case of a union of the results of a function over the atoms.+atom_union :: (IsFormula formula, Ord r) => (AtomOf formula -> Set r) -> formula -> Set r+atom_union f fm = overatoms (\h t -> Set.union (f h) t) fm Set.empty
+ src/Data/Logic/ATP/Herbrand.hs view
@@ -0,0 +1,311 @@+-- | Relation between FOL and propositonal logic; Herbrand theorem.+--+-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Logic.ATP.Herbrand where++import Data.Logic.ATP.Apply (functions, HasApply(TermOf))+import Data.Logic.ATP.DP (dpll)+import Data.Logic.ATP.FOL (IsFirstOrder, lsubst, fv, generalize)+import Data.Logic.ATP.Formulas (IsFormula(AtomOf), overatoms, atomic)+import Data.Logic.ATP.Lib (allpairs, distrib)+import Data.Logic.ATP.Lit ((.~.), JustLiteral, LFormula)+import Data.Logic.ATP.Parser(fof)+import Data.Logic.ATP.Pretty (prettyShow)+import Data.Logic.ATP.Prop (eval, JustPropositional, PFormula, simpcnf, simpdnf, trivial)+import Data.Logic.ATP.Skolem (Formula, HasSkolem(SVarOf), runSkolem, skolemize)+import Data.Logic.ATP.Term (Arity, IsTerm(TVarOf, FunOf), fApp)+import qualified Data.Map.Strict as Map+import Data.Set as Set+import Data.String (IsString(..))+import Debug.Trace+import Test.HUnit hiding (tried)++-- | Propositional valuation.+pholds :: (JustPropositional pf) => (AtomOf pf -> Bool) -> pf -> Bool+pholds d fm = eval fm d++-- | Get the constants for Herbrand base, adding nullary one if necessary.+herbfuns :: (atom ~ AtomOf fof, term ~ TermOf atom, function ~ FunOf term, IsFormula fof, HasApply atom, Ord function) => fof -> (Set (function, Arity), Set (function, Arity))+herbfuns fm =+  let (cns,fns) = Set.partition (\ (_,ar) -> ar == 0) (functions 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 :: (v ~ TVarOf term, f ~ FunOf term, IsTerm term) => Set term -> Set (f, Arity) -> Int -> Set term+groundterms cntms _ 0 = cntms+groundterms cntms fns n =+    Set.fold terms Set.empty fns+    where+      terms (f,m) l = Set.union (Set.map (fApp f) (groundtuples cntms fns (n - 1) m)) l++groundtuples :: (v ~ TVarOf term, f ~ FunOf term, IsTerm term) => Set term -> Set (f, Int) -> Int -> Int -> Set [term]+groundtuples _ _ 0 0 = Set.singleton []+groundtuples _ _ _ 0 = Set.empty+groundtuples cntms fns n m =+    Set.fold tuples Set.empty (Set.fromList [0 .. n])+    where+      tuples k l = Set.union (allpairs (:) (groundterms cntms fns k) (groundtuples cntms fns (n - k) (m - 1))) l++-- | Iterate modifier "mfn" over ground terms till "tfn" fails.+herbloop :: forall lit atom function v term.+            (atom ~ AtomOf lit, term ~ TermOf atom, function ~ FunOf term, v ~ TVarOf term, v ~ SVarOf function,+             JustLiteral lit,+             HasApply atom,+             IsTerm term) =>+            (Set (Set lit) -> (lit -> lit) -> Set (Set lit) -> Set (Set lit))+         -> (Set (Set lit) -> Bool)+         -> Set (Set lit)+         -> Set term+         -> Set (function, Int)+         -> [TVarOf term]+         -> Int+         -> Set (Set lit)+         -> Set [term]+         -> Set [term]+         -> Set [term]+herbloop mfn tfn fl0 cntms fns fvs n fl tried tuples =+  let debug x = trace (show (size tried) ++ " ground instances tried; " ++ show (length fl) ++ " items in list") x in+  case Set.minView (debug tuples) of+    Nothing ->+          let newtups = groundtuples cntms fns n (length fvs) in+          herbloop mfn tfn fl0 cntms fns fvs (n + 1) fl tried newtups+    Just (tup, tups) ->+        let fpf' = Map.fromList (zip fvs tup) in+        let fl' = mfn fl0 (lsubst fpf') fl in+        if not (tfn fl') then Set.insert tup tried+        else herbloop mfn tfn fl0 cntms fns fvs n fl' (Set.insert tup tried) tups++-- | Hence a simple Gilmore-type procedure.+gilmore_loop :: (atom ~ AtomOf lit, term ~ TermOf atom, function ~ FunOf term, v ~ TVarOf term, v ~ SVarOf function,+                 JustLiteral lit, Ord lit,+                 HasApply atom,+                 IsTerm term) =>+                Set (Set lit)+             -> Set term+             -> Set (function, Int)+             -> [TVarOf term]+             -> Int+             -> Set (Set lit)+             -> Set [term]+             -> Set [term]+             -> Set [term]+gilmore_loop =+    herbloop mfn (not . Set.null)+    where+      mfn djs0 ifn djs = Set.filter (not . trivial) (distrib (Set.map (Set.map ifn) djs0) djs)++gilmore :: forall fof atom term v function.+           (IsFirstOrder fof, Ord fof, HasSkolem function,+            atom ~ AtomOf fof,+            term ~ TermOf atom,+            function ~ FunOf term,+            v ~ TVarOf term,+            v ~ SVarOf function) =>+           fof -> Int+gilmore fm =+  let (sfm :: PFormula atom) = runSkolem (skolemize id ((.~.) (generalize fm))) in+  let fvs = Set.toList (overatoms (\ a s -> Set.union s (fv (atomic a :: fof))) sfm (Set.empty))+      (consts,fns) = herbfuns sfm in+  let cntms = Set.map (\ (c,_) -> fApp c []) consts in+  Set.size (gilmore_loop (simpdnf id sfm :: Set (Set (LFormula atom))) cntms fns (fvs) 0 (Set.singleton Set.empty) Set.empty Set.empty)++-- | First example and a little tracing.+test01 :: Test+test01 =+    let fm = [fof| exists x. (forall y. p(x) ==> p(y)) |]+        expected = 2+    in+    TestCase (assertString (case gilmore fm of+                              r | r == expected -> ""+                              r -> "gilmore(" ++ prettyShow fm ++ ") -> " ++ show r ++ ", expected: " ++ show expected))++-- -------------------------------------------------------------------------+-- Quick example.+-- -------------------------------------------------------------------------++p24 :: Test+p24 =+     let label = "gilmore p24 (p. 160): " ++ prettyShow fm+         fm = [fof|~(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)))|] in+    TestLabel label $ TestCase $ assertEqual label 1 (gilmore fm)++-- | Slightly less easy example.  Expected output:+-- +-- 0 ground instances tried; 1 items in list+-- 0 ground instances tried; 1 items in list+-- 1 ground instances tried; 13 items in list+-- 1 ground instances tried; 13 items in list+-- 2 ground instances tried; 57 items in list+-- 3 ground instances tried; 84 items in list+-- 4 ground instances tried; 405 items in list+p45fm :: Formula+p45fm =      [fof| (((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))))))) |]+p45 :: Test+p45 = TestLabel "gilmore p45" $ TestCase $ assertEqual "gilmore p45" 5 (gilmore p45fm)+{-+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 => Set (Set a) -> (a -> b) -> Set (Set b) -> Set (Set b)+dp_mfn cjs0 ifn cjs = Set.union (Set.map (Set.map ifn) cjs0) cjs++dp_loop :: (atom ~ AtomOf lit, term ~ TermOf atom, function ~ FunOf term, v ~ TVarOf term, v ~ SVarOf function,+            JustLiteral lit, Ord lit,+            HasApply atom,+            IsTerm term) =>+           Set (Set lit)+        -> Set term+        -> Set (function, Int)+        -> [v]+        -> Int+        -> Set (Set lit)+        -> Set [term]+        -> Set [term]+        -> Set [term]+dp_loop = herbloop dp_mfn dpll++davisputnam :: forall formula atom term v function.+               (IsFirstOrder formula, Ord formula, HasSkolem function,+                atom ~ AtomOf formula,+                term ~ TermOf atom,+                function ~ FunOf term,+                v ~ TVarOf term,+                v ~ SVarOf function) =>+               formula -> Int+davisputnam fm =+  let (sfm :: PFormula atom) = runSkolem (skolemize id ((.~.)(generalize fm))) in+  let fvs = Set.toList (overatoms (\ a s -> Set.union (fv (atomic a :: formula)) s) sfm Set.empty)+      (consts,fns) = herbfuns sfm in+  let cntms = Set.map (\ (c,_) -> fApp c []) consts in+  Set.size (dp_loop (simpcnf id sfm :: Set (Set (LFormula atom))) cntms fns fvs 0 Set.empty Set.empty Set.empty)++{-+-- | 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;;+-}++-- | Show how few of the instances we really need. Hence unification!+davisputnam' :: forall formula atom term v function.+                (IsFirstOrder formula, Ord formula, HasSkolem function,+                 atom ~ AtomOf formula,+                 term ~ TermOf atom,+                 function ~ FunOf term,+                 v ~ TVarOf term,+                 v ~ SVarOf function) =>+                formula -> formula -> formula -> Int+davisputnam' _ _ fm =+    let (sfm :: PFormula atom) = runSkolem (skolemize id ((.~.)(generalize fm))) in+    let fvs = Set.toList (overatoms (\ (a :: AtomOf formula) s -> Set.union (fv (atomic a :: formula)) s) sfm Set.empty)+        consts :: Set (function, Arity)+        fns :: Set (function, Arity)+        (consts,fns) = herbfuns sfm in+    let cntms :: Set (TermOf (AtomOf formula))+        cntms = Set.map (\ (c,_) -> fApp c []) consts in+    Set.size (dp_refine_loop (simpcnf id sfm :: Set (Set (LFormula atom))) cntms fns fvs 0 Set.empty Set.empty Set.empty)++-- | Try to cut out useless instantiations in final result.+dp_refine_loop :: (atom ~ AtomOf lit, term ~ TermOf atom, function ~ FunOf term, v ~ TVarOf term, v ~ SVarOf function,+                   JustLiteral lit, Ord lit,+                   IsTerm term,+                   HasApply atom) =>+                  Set (Set lit)+               -> Set term+               -> Set (function, Int)+               -> [v]+               -> Int+               -> Set (Set lit)+               -> Set [term]+               -> Set [term]+               -> Set [term]+dp_refine_loop cjs0 cntms fns fvs n cjs tried tuples =+    let tups = dp_loop cjs0 cntms fns fvs n cjs tried tuples in+    dp_refine cjs0 fvs tups Set.empty++dp_refine :: (atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term,+              HasApply atom,+              JustLiteral lit, Ord lit,+              IsTerm term+             ) => Set (Set lit) -> [TVarOf term] -> Set [term] -> Set [term] -> Set [term]+dp_refine cjs0 fvs dknow need =+    case Set.minView dknow of+      Nothing -> need+      Just (cl, dknow') ->+          let mfn = dp_mfn cjs0 . lsubst . Map.fromList . zip fvs in+          let flag = dpll (Set.fold mfn Set.empty (Set.union need dknow')) in+          dp_refine cjs0 fvs dknow' (if flag then Set.insert cl need else need)++{-+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;;+-}++testHerbrand :: Test+testHerbrand = TestLabel "Herbrand" (TestList [test01, p24, p45])
+ src/Data/Logic/ATP/Lib.hs view
@@ -0,0 +1,1018 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-unused-binds #-}++module Data.Logic.ATP.Lib+    ( Failing(Success, Failure)+    , failing+    , SetLike(slView, slMap, slUnion, slEmpty, slSingleton), slInsert, prettyFoldable++    , setAny+    , setAll+    , flatten+    -- , itlist2+    -- , itlist  -- same as foldr with last arguments flipped+    , tryfind+    , tryfindM+    , runRS+    , evalRS+    , settryfind+    -- , end_itlist -- same as foldr1+    , (|=>)+    , (|->)+    , fpf+    -- * Time and timeout+    , timeComputation+    , timeMessage+    , time+    , timeout+    , compete+    -- * Map aliases+    , defined+    , undefine+    , apply+    -- , exists+    , tryApplyD+    , allpairs+    , distrib+    , image+    , optimize+    , minimize+    , maximize+    , can+    , allsets+    , allsubsets+    , allnonemptysubsets+    , mapfilter+    , setmapfilter+    , (∅)+    , deepen, Depth(Depth)+    , testLib+    ) where++import Control.Applicative (Alternative(empty, (<|>)))+import Control.Concurrent (forkIO, killThread, newEmptyMVar, putMVar, takeMVar, threadDelay)+import Control.Monad.RWS (evalRWS, runRWS, RWS)+import Data.Data (Data)+import Data.Foldable as Foldable+import Data.Function (on)+import qualified Data.List as List (map)+import Data.Map.Strict as Map (delete, findMin, insert, lookup, Map, member, singleton)+import Data.Maybe+import Data.Monoid ((<>))+import Data.Sequence as Seq (Seq, viewl, ViewL(EmptyL, (:<)), (><), singleton)+import Data.Set as Set (delete, empty, fold, fromList, insert, minView, Set, singleton, union)+import qualified Data.Set as Set (map)+import Data.Time.Clock (DiffTime, diffUTCTime, getCurrentTime, NominalDiffTime)+import Data.Typeable (Typeable)+import Debug.Trace (trace)+import Prelude hiding (map)+import System.IO (hPutStrLn, stderr)+import Text.PrettyPrint.HughesPJClass (Doc, fsep, punctuate, comma, space, Pretty(pPrint), text)+import Test.HUnit (assertEqual, Test(TestCase, TestLabel, TestList))++-- | An error idiom.  Rather like the error monad, but collect all+-- errors together+data Failing a = Success a | Failure [ErrorMsg] deriving Show+type ErrorMsg = String++instance Functor Failing where+  fmap _ (Failure fs) = Failure fs+  fmap f (Success a) = Success (f a)++instance Applicative Failing where+   pure = Success+   Failure msgs <*> Failure msgs' = Failure (msgs ++ msgs')+   Success _ <*> Failure msgs' = Failure msgs'+   Failure msgs' <*> Success _ = Failure msgs'+   Success f <*> Success x = Success (f x)++instance Alternative Failing where+  empty                       = Failure []+  (Success x) <|> _           = Success x+  _           <|> (Success y) = Success y+  (Failure x) <|> (Failure y) = Failure (x ++ y)++failing :: ([String] -> b) -> (a -> b) -> Failing a -> b+failing f _ (Failure errs) = f errs+failing _ f (Success a)    = f a++-- Declare a Monad instance for Failing so we can chain a series of+-- Failing actions with >> or >>=.  If any action fails the subsequent+-- actions in the chain will be aborted.+instance Monad Failing where+  return = Success+  m >>= f =+      case m of+        (Failure errs) -> (Failure errs)+        (Success a) -> f a+  fail errMsg = Failure [errMsg]++deriving instance Typeable Failing+deriving instance Data a => Data (Failing a)+deriving instance Read a => Read (Failing a)+deriving instance Eq a => Eq (Failing a)+deriving instance Ord a => Ord (Failing a)++instance Pretty a => Pretty (Failing a) where+    pPrint (Failure ss) = text (unlines ("Failures:" : List.map ("  " ++) ss))+    pPrint (Success a) = pPrint a++-- | A simple class, slightly more powerful than Foldable, so we can+-- write functions that operate on the elements of a set or a list.+class Foldable c => SetLike c where+    slView :: forall a. c a -> Maybe (a, c a)+    slMap :: forall a b. Ord b => (a -> b) -> c a -> c b+    slUnion :: Ord a => c a -> c a -> c a+    slEmpty :: c a+    slSingleton :: a -> c a++instance SetLike Set where+    slView = Set.minView+    slMap = Set.map+    slUnion = Set.union+    slEmpty = Set.empty+    slSingleton = Set.singleton++instance SetLike [] where+    slView [] = Nothing+    slView (h : t) = Just (h, t)+    slMap = List.map+    slUnion = (<>)+    slEmpty = mempty+    slSingleton = (: [])++instance SetLike Seq where+    slView s = case viewl s of+               EmptyL -> Nothing+               h :< t -> Just (h, t)+    slMap = fmap+    slUnion = (><)+    slEmpty = mempty+    slSingleton = Seq.singleton++slInsert :: (SetLike set, Ord a) => a -> set a -> set a+slInsert x s = slUnion (slSingleton x) s++prettyFoldable :: (Foldable t, Pretty a) => t a -> Doc+prettyFoldable s = fsep (punctuate (comma <> space) (List.map pPrint (Foldable.foldr (:) [] s)))++--instance (Pretty a, SetLike set) => Pretty (set a) where+--    pPrint = prettyFoldable++(∅) :: (Monoid (c a), SetLike c) => c a+(∅) = mempty++setAny :: Foldable t => (a -> Bool) -> t a -> Bool+setAny = any++setAll :: Foldable t => (a -> Bool) -> t a -> Bool+setAll = all++flatten :: Ord a => Set (Set a) -> Set a+flatten ss' = Set.fold Set.union Set.empty ss'++{-+(* ========================================================================= *)+(* Misc library functions to set up a nice environment.                      *)+(* ========================================================================= *)++let identity x = x;;++let ( ** ) = fun f g x -> f(g x);;++(* ------------------------------------------------------------------------- *)+(* GCD and LCM on arbitrary-precision numbers.                               *)+(* ------------------------------------------------------------------------- *)++let gcd_num n1 n2 =+  abs_num(num_of_big_int+      (Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2)));;++let lcm_num n1 n2 = abs_num(n1 */ n2) // gcd_num n1 n2;;++(* ------------------------------------------------------------------------- *)+(* A useful idiom for "non contradictory" etc.                               *)+(* ------------------------------------------------------------------------- *)++let non p x = not(p x);;++(* ------------------------------------------------------------------------- *)+(* Kind of assertion checking.                                               *)+(* ------------------------------------------------------------------------- *)++let check p x = if p(x) then x else failwith "check";;++(* ------------------------------------------------------------------------- *)+(* Repetition of a function.                                                 *)+(* ------------------------------------------------------------------------- *)++let rec funpow n f x =+  if n < 1 then x else funpow (n-1) f (f x);;+-}+-- let can f x = try f x; true with Failure _ -> false;;+can :: (t -> Failing a) -> t -> Bool+can f x = failing (const True) (const False) (f x)++{-+let rec repeat f x = try repeat f (f x) with Failure _ -> x;;++(* ------------------------------------------------------------------------- *)+(* Handy list operations.                                                    *)+(* ------------------------------------------------------------------------- *)++let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);;++let rec (---) = fun m n -> if m >/ n then [] else m::((m +/ Int 1) --- n);;++let rec map2 f l1 l2 =+  match (l1,l2) with+    [],[] -> []+  | (h1::t1),(h2::t2) -> let h = f h1 h2 in h::(map2 f t1 t2)+  | _ -> failwith "map2: length mismatch";;++let rev =+  let rec rev_append acc l =+    match l with+      [] -> acc+    | h::t -> rev_append (h::acc) t in+  fun l -> rev_append [] l;;++let hd l =+  match l with+   h::t -> h+  | _ -> failwith "hd";;++let tl l =+  match l with+   h::t -> t+  | _ -> failwith "tl";;+-}++-- (^) = (++)++itlist :: Foldable t => (a -> b -> b) -> t a -> b -> b+itlist f xs z = Foldable.foldr f z xs++end_itlist :: Foldable t => (a -> a -> a) -> t a -> a+end_itlist = Foldable.foldr1++itlist2 :: (SetLike s, SetLike t) =>+           (a -> b -> Failing r -> Failing r) ->+           s a -> t b -> Failing r -> Failing r+itlist2 f s t r =+    case (slView s, slView t) of+      (Nothing, Nothing) -> r+      (Just (a, s'), Just (b, t')) ->+          f a b (itlist2 f s' t' r)+      _ -> Failure ["itlist2"]++{-+let rec zip l1 l2 =+  match (l1,l2) with+        ([],[]) -> []+      | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2)+      | _ -> failwith "zip";;++let rec forall p l =+  match l with+    [] -> true+  | h::t -> p(h) & forall p t;;+-}+exists :: Foldable t => (a -> Bool) -> t a -> Bool+exists = any+{-+let partition p l =+    itlist (fun a (yes,no) -> if p a then a::yes,no else yes,a::no) l ([],[]);;++let filter p l = fst(partition p l);;++let length =+  let rec len k l =+    if l = [] then k else len (k + 1) (tl l) in+  fun l -> len 0 l;;++let rec last l =+  match l with+    [x] -> x+  | (h::t) -> last t+  | [] -> failwith "last";;++let rec butlast l =+  match l with+    [_] -> []+  | (h::t) -> h::(butlast t)+  | [] -> failwith "butlast";;++let rec find p l =+  match l with+      [] -> failwith "find"+    | (h::t) -> if p(h) then h else find p t;;++let rec el n l =+  if n = 0 then hd l else el (n - 1) (tl l);;++let map f =+  let rec mapf l =+    match l with+      [] -> []+    | (x::t) -> let y = f x in y::(mapf t) in+  mapf;;+-}++-- allpairs :: forall a b c. (Ord c) => (a -> b -> c) -> Set a -> Set b -> Set c+-- allpairs f xs ys = Set.fold (\ x zs -> Set.fold (\ y zs' -> Set.insert (f x y) zs') zs ys) Set.empty xs++allpairs :: forall a b c set. (SetLike set, Ord c) => (a -> b -> c) -> set a -> set b -> set c+allpairs f xs ys = Foldable.foldr (\ x zs -> Foldable.foldr (g x) zs ys) slEmpty xs+    where g :: a -> b -> set c -> set c+          g x y zs' = slInsert (f x y) zs'++distrib :: Ord a => Set (Set a) -> Set (Set a) -> Set (Set a)+distrib s1 s2 = allpairs (Set.union) s1 s2++test01 :: Test+test01 = TestCase $ assertEqual "allpairs" expected input+    where input = allpairs (,) (Set.fromList [1,2,3]) (Set.fromList [4,5,6])+          expected = Set.fromList [(1,4),(1,5),(1,6),(2,4),(2,5),(2,6),(3,4),(3,5),(3,6)] :: Set (Int, Int)++{-+let rec distinctpairs l =+  match l with+   x::t -> itlist (fun y a -> (x,y) :: a) t (distinctpairs t)+  | [] -> [];;++let rec chop_list n l =+  if n = 0 then [],l else+  try let m,l' = chop_list (n-1) (tl l) in (hd l)::m,l'+  with Failure _ -> failwith "chop_list";;++let replicate n a = map (fun x -> a) (1--n);;++let rec insertat i x l =+  if i = 0 then x::l else+  match l with+    [] -> failwith "insertat: list too short for position to exist"+  | h::t -> h::(insertat (i-1) x t);;++let rec forall2 p l1 l2 =+  match (l1,l2) with+    [],[] -> true+  | (h1::t1,h2::t2) -> p h1 h2 & forall2 p t1 t2+  | _ -> false;;++let index x =+  let rec ind n l =+    match l with+      [] -> failwith "index"+    | (h::t) -> if Pervasives.compare x h = 0 then n else ind (n + 1) t in+  ind 0;;++let rec unzip l =+  match l with+    [] -> [],[]+  | (x,y)::t ->+      let xs,ys = unzip t in x::xs,y::ys;;++(* ------------------------------------------------------------------------- *)+(* Whether the first of two items comes earlier in the list.                 *)+(* ------------------------------------------------------------------------- *)++let rec earlier l x y =+  match l with+    h::t -> (Pervasives.compare h y <> 0) &+            (Pervasives.compare h x = 0 or earlier t x y)+  | [] -> false;;++(* ------------------------------------------------------------------------- *)+(* Application of (presumably imperative) function over a list.              *)+(* ------------------------------------------------------------------------- *)++let rec do_list f l =+  match l with+    [] -> ()+  | h::t -> f(h); do_list f t;;++(* ------------------------------------------------------------------------- *)+(* Association lists.                                                        *)+(* ------------------------------------------------------------------------- *)++let rec assoc a l =+  match l with+    (x,y)::t -> if Pervasives.compare x a = 0 then y else assoc a t+  | [] -> failwith "find";;++let rec rev_assoc a l =+  match l with+    (x,y)::t -> if Pervasives.compare y a = 0 then x else rev_assoc a t+  | [] -> failwith "find";;++(* ------------------------------------------------------------------------- *)+(* Merging of sorted lists (maintaining repetitions).                        *)+(* ------------------------------------------------------------------------- *)++let rec merge ord l1 l2 =+  match l1 with+    [] -> l2+  | h1::t1 -> match l2 with+                [] -> l1+              | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2)+                          else h2::(merge ord l1 t2);;++(* ------------------------------------------------------------------------- *)+(* Bottom-up mergesort.                                                      *)+(* ------------------------------------------------------------------------- *)++let sort ord =+  let rec mergepairs l1 l2 =+    match (l1,l2) with+        ([s],[]) -> s+      | (l,[]) -> mergepairs [] l+      | (l,[s1]) -> mergepairs (s1::l) []+      | (l,(s1::s2::ss)) -> mergepairs ((merge ord s1 s2)::l) ss in+  fun l -> if l = [] then [] else mergepairs [] (map (fun x -> [x]) l);;++(* ------------------------------------------------------------------------- *)+(* Common measure predicates to use with "sort".                             *)+(* ------------------------------------------------------------------------- *)++let increasing f x y = Pervasives.compare (f x) (f y) < 0;;++let decreasing f x y = Pervasives.compare (f x) (f y) > 0;;++(* ------------------------------------------------------------------------- *)+(* Eliminate repetitions of adjacent elements, with and without counting.    *)+(* ------------------------------------------------------------------------- *)++let rec uniq l =+  match l with+    x::(y::_ as t) -> let t' = uniq t in+                      if Pervasives.compare x y = 0 then t' else+                      if t'==t then l else x::t'+ | _ -> l;;++let repetitions =+  let rec repcount n l =+    match l with+      x::(y::_ as ys) -> if Pervasives.compare y x = 0 then repcount (n + 1) ys+                  else (x,n)::(repcount 1 ys)+    | [x] -> [x,n]+    | [] -> failwith "repcount" in+  fun l -> if l = [] then [] else repcount 1 l;;+-}++tryfind :: Foldable t => (a -> Failing r) -> t a -> Failing r+tryfind p s = maybe (Failure ["tryfind"]) p (find (failing (const False) (const True) . p) s)++tryfindM :: Monad m => (t -> m (Failing a)) -> [t] -> m (Failing a)+tryfindM _ [] = return $ Failure ["tryfindM"]+tryfindM f (h : t) = f h >>= failing (\_ -> tryfindM f t) (return . Success)++evalRS :: RWS r () s a -> r -> s -> a+evalRS action r s = fst $ evalRWS action r s++runRS :: RWS r () s a -> r -> s -> (a, s)+runRS action r s = (\(a, s', _w) -> (a, s')) $ runRWS action r s++test02 :: Test+test02 =+    TestCase $+    assertEqual+      "tryfind on infinite list"+      (Success 3 :: Failing Int)+      (tryfind (\x -> if x == 3+                      then Success 3+                      else Failure ["test02"]) ([1..] :: [Int]))++settryfind :: (t -> Failing a) -> Set t -> Failing a+settryfind f l =+    case Set.minView l of+      Nothing -> Failure ["settryfind"]+      Just (h, t) -> failing (\ _ -> settryfind f t) Success (f h)++mapfilter :: (a -> Failing b) -> [a] -> [b]+mapfilter f l = catMaybes (List.map (failing (const Nothing) Just . f) l)+    -- filter (failing (const False) (const True)) (map f l)++setmapfilter :: Ord b => (a -> Failing b) -> Set a -> Set b+setmapfilter f s = Set.fold (\ a r -> failing (const r) (`Set.insert` r) (f a)) Set.empty s++-- -------------------------------------------------------------------------+-- Find list member that maximizes or minimizes a function.+-- -------------------------------------------------------------------------++optimize :: forall s a b. (SetLike s, Foldable s) => (b -> b -> Ordering) -> (a -> b) -> s a -> Maybe a+optimize _ _ l | isNothing (slView l) = Nothing+optimize ord f l = Just (Foldable.maximumBy (ord `on` f) l)++maximize :: (Ord b, SetLike s, Foldable s) => (a -> b) -> s a -> Maybe a+maximize = optimize compare++minimize :: (Ord b, SetLike s, Foldable s) => (a -> b) -> s a -> Maybe a+minimize = optimize (flip compare)++-- -------------------------------------------------------------------------+-- Set operations on ordered lists.+-- -------------------------------------------------------------------------+{-+let setify =+  let rec canonical lis =+     match lis with+       x::(y::_ as rest) -> Pervasives.compare x y < 0 & canonical rest+     | _ -> true in+  fun l -> if canonical l then l+           else uniq (sort (fun x y -> Pervasives.compare x y <= 0) l);;++let union =+  let rec union l1 l2 =+    match (l1,l2) with+        ([],l2) -> l2+      | (l1,[]) -> l1+      | ((h1::t1 as l1),(h2::t2 as l2)) ->+          if h1 = h2 then h1::(union t1 t2)+          else if h1 < h2 then h1::(union t1 l2)+          else h2::(union l1 t2) in+  fun s1 s2 -> union (setify s1) (setify s2);;++let intersect =+  let rec intersect l1 l2 =+    match (l1,l2) with+        ([],l2) -> []+      | (l1,[]) -> []+      | ((h1::t1 as l1),(h2::t2 as l2)) ->+          if h1 = h2 then h1::(intersect t1 t2)+          else if h1 < h2 then intersect t1 l2+          else intersect l1 t2 in+  fun s1 s2 -> intersect (setify s1) (setify s2);;++let subtract =+  let rec subtract l1 l2 =+    match (l1,l2) with+        ([],l2) -> []+      | (l1,[]) -> l1+      | ((h1::t1 as l1),(h2::t2 as l2)) ->+          if h1 = h2 then subtract t1 t2+          else if h1 < h2 then h1::(subtract t1 l2)+          else subtract l1 t2 in+  fun s1 s2 -> subtract (setify s1) (setify s2);;++let subset,psubset =+  let rec subset l1 l2 =+    match (l1,l2) with+        ([],l2) -> true+      | (l1,[]) -> false+      | (h1::t1,h2::t2) ->+          if h1 = h2 then subset t1 t2+          else if h1 < h2 then false+          else subset l1 t2+  and psubset l1 l2 =+    match (l1,l2) with+        (l1,[]) -> false+      | ([],l2) -> true+      | (h1::t1,h2::t2) ->+          if h1 = h2 then psubset t1 t2+          else if h1 < h2 then false+          else subset l1 t2 in+  (fun s1 s2 -> subset (setify s1) (setify s2)),+  (fun s1 s2 -> psubset (setify s1) (setify s2));;++let rec set_eq s1 s2 = (setify s1 = setify s2);;++let insert x s = union [x] s;;+-}++image :: (Ord b, Ord a) => (a -> b) -> Set a -> Set b+image f s = Set.map f s++{-+(* ------------------------------------------------------------------------- *)+(* Union of a family of sets.                                                *)+(* ------------------------------------------------------------------------- *)++let unions s = setify(itlist (@) s []);;++(* ------------------------------------------------------------------------- *)+(* List membership. This does *not* assume the list is a set.                *)+(* ------------------------------------------------------------------------- *)++let rec mem x lis =+  match lis with+    [] -> false+  | (h::t) -> Pervasives.compare x h = 0 or mem x t;;+-}++-- -------------------------------------------------------------------------+-- Finding all subsets or all subsets of a given size.+-- -------------------------------------------------------------------------++-- allsets :: Ord a => Int -> Set a -> Set (Set a)+allsets :: forall a b. (Num a, Eq a, Ord b) => a -> Set b -> 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 a -> Set (Set a)+allsubsets s =+    maybe (Set.singleton Set.empty)+          (\ (x, t) ->+               let res = allsubsets t in+               Set.union res (Set.map (Set.insert x) res))+          (Set.minView s)+++allnonemptysubsets :: forall a. Ord a => Set a -> Set (Set a)+allnonemptysubsets s = Set.delete Set.empty (allsubsets s)++{-+(* ------------------------------------------------------------------------- *)+(* Explosion and implosion of strings.                                       *)+(* ------------------------------------------------------------------------- *)++let explode s =+  let rec exap n l =+     if n < 0 then l else+      exap (n - 1) ((String.sub s n 1)::l) in+  exap (String.length s - 1) [];;++let implode l = itlist (^) l "";;++(* ------------------------------------------------------------------------- *)+(* Timing; useful for documentation but not logically necessary.             *)+(* ------------------------------------------------------------------------- *)++let time f x =+  let start_time = Sys.time() in+  let result = f x in+  let finish_time = Sys.time() in+  print_string+    ("CPU time (user): "^(string_of_float(finish_time -. start_time)));+  print_newline();+  result;;+-}++-- | Perform an IO operation and return the elapsed time along with the result.+timeComputation :: IO r -> IO (r, NominalDiffTime)+timeComputation a = do+  start <- getCurrentTime+  r <- a+  end <- getCurrentTime+  return (r, diffUTCTime end start)++-- | Perform an IO operation and output a message about how long it took.+timeMessage :: (r -> NominalDiffTime -> String) -> IO r -> IO r+timeMessage pp a = do+  (r, e) <- timeComputation a+  hPutStrLn stderr (pp r e)+  return r++-- | Output elapsed time+time :: IO r -> IO r+time a = timeMessage (\_ e -> "Computation time: " ++ show e) a++-- | Allow a computation to proceed for a given amount of time.+timeout :: String -> DiffTime -> IO r -> IO (Either String r)+timeout message delay a = do+  compete [threadDelay (fromEnum (realToFrac (delay / 1e6) :: Rational)) >> return (Left message),+           Right <$> a]++-- | Run several IO operations in parallel, return the result of the+-- first one that completes and kill the others.+compete :: [IO a] -> IO a+compete actions = do+  mvar <- newEmptyMVar+  tids <- mapM (\action -> forkIO $ action >>= putMVar mvar) actions+  result <- takeMVar mvar+  mapM_ killThread tids+  return result++-- | Polymorphic finite partial functions via Patricia trees.+--+-- The point of this strange representation is that it is canonical (equal+-- functions have the same encoding) yet reasonably efficient on average.+--+-- Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10).+data Func a b+    = Empty+    | Leaf Int [(a, b)]+    | Branch Int Int (Func a b) (Func a b)++-- | Undefined function.+undefinedFunction :: Func a b+undefinedFunction = Empty++-- -------------------------------------------------------------------------+-- In case of equality comparison worries, better use this.+-- -------------------------------------------------------------------------++isUndefined :: Func a b -> Bool+isUndefined Empty = True+isUndefined _ = False++-- -------------------------------------------------------------------------+-- Operation analogous to "map" for functions.+-- -------------------------------------------------------------------------++mapf :: (b -> c) -> Func a b -> Func a c+mapf f t =+    case t of+      Empty -> Empty+      Leaf h l -> Leaf h (map_list f l)+      Branch p b l r -> Branch p b (mapf f l) (mapf f r)+    where+      map_list f' l' =+          case l' of+            [] -> []+            (x,y) : t' -> (x, f' y) : map_list f' t'++-- -------------------------------------------------------------------------+-- Operations analogous to "fold" for lists.+-- -------------------------------------------------------------------------++foldlFn :: (r -> a -> b -> r) -> r -> Func a b -> r+foldlFn f a t =+    case t of+      Empty -> a+      Leaf _h l -> foldl_list f a l+      Branch _p _b l r -> foldlFn f (foldlFn f a l) r+    where+      foldl_list _f a' l =+          case l of+            [] -> a'+            (x,y) : t' -> foldl_list f (f a' x y) t'++foldrFn :: (a -> b -> r -> r) -> Func a b -> r -> r+foldrFn f t a =+    case t of+      Empty -> a+      Leaf _h l -> foldr_list f l a+      Branch _p _b l r -> foldrFn f l (foldrFn f r a)+    where+      foldr_list f' l a' =+          case l of+            [] -> a'+            (x, y) : t' -> f' x y (foldr_list f' t' a')++-- -------------------------------------------------------------------------+-- Mapping to sorted-list representation of the graph, domain and range.+-- -------------------------------------------------------------------------++graph :: (Ord a, Ord b) => Func a b -> Set (a, b)+graph f = Set.fromList (foldlFn (\ a x y -> (x,y) : a) [] f)++dom :: Ord a => Func a b -> Set a+dom f = Set.fromList (foldlFn (\ a x _y -> x :a) [] f)++ran :: Ord b => Func a b -> Set b+ran f = Set.fromList (foldlFn (\ a _x y -> y : a) [] f)++-- -------------------------------------------------------------------------+-- Application.+-- -------------------------------------------------------------------------++applyD :: Ord k => Map k a -> k -> a -> Map k a+applyD m k a = Map.insert k a m++apply :: Ord k => Map k a -> k -> Maybe a+apply m k = Map.lookup k m++tryApplyD :: Ord k => Map k a -> k -> a -> a+tryApplyD m k d = fromMaybe d (Map.lookup k m)++tryApplyL :: Ord k => Map k [a] -> k -> [a]+tryApplyL m k = tryApplyD m k []+{-+applyD :: (t -> Maybe b) -> (t -> b) -> t -> b+applyD f d x = maybe (d x) id (f x)++apply :: (t -> Maybe b) -> t -> b+apply f = applyD f (\ _ -> error "apply")++tryApplyD :: (t -> Maybe b) -> t -> b -> b+tryApplyD f a d = maybe d id (f a)++tryApplyL :: (t -> Maybe [a]) -> t -> [a]+tryApplyL f x = tryApplyD f x []+-}++defined :: Ord t => Map t a -> t -> Bool+defined = flip Map.member++-- | Undefinition.+undefine :: forall k a. Ord k => k -> Map k a -> Map k a+undefine k mp = Map.delete k mp++{-+(* ------------------------------------------------------------------------- *)+(* Redefinition and combination.                                             *)+(* ------------------------------------------------------------------------- *)++let (|->),combine =+  let newbranch p1 t1 p2 t2 =+    let zp = p1 lxor p2 in+    let b = zp land (-zp) in+    let p = p1 land (b - 1) in+    if p1 land b = 0 then Branch(p,b,t1,t2)+    else Branch(p,b,t2,t1) in+  let rec define_list (x,y as xy) l =+    match l with+      (a,b as ab)::t ->+          let c = Pervasives.compare x a in+          if c = 0 then xy::t+          else if c < 0 then xy::l+          else ab::(define_list xy t)+    | [] -> [xy]+  and combine_list op z l1 l2 =+    match (l1,l2) with+      [],_ -> l2+    | _,[] -> l1+    | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) ->+          let c = Pervasives.compare x1 x2 in+          if c < 0 then xy1::(combine_list op z t1 l2)+          else if c > 0 then xy2::(combine_list op z l1 t2) else+          let y = op y1 y2 and l = combine_list op z t1 t2 in+          if z(y) then l else (x1,y)::l in+  let (|->) x y =+    let k = Hashtbl.hash x in+    let rec upd t =+      match t with+        Empty -> Leaf (k,[x,y])+      | Leaf(h,l) ->+           if h = k then Leaf(h,define_list (x,y) l)+           else newbranch h t k (Leaf(k,[x,y]))+      | Branch(p,b,l,r) ->+          if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y]))+          else if k land b = 0 then Branch(p,b,upd l,r)+          else Branch(p,b,l,upd r) in+    upd in+  let rec combine op z t1 t2 =+    match (t1,t2) with+      Empty,_ -> t2+    | _,Empty -> t1+    | Leaf(h1,l1),Leaf(h2,l2) ->+          if h1 = h2 then+            let l = combine_list op z l1 l2 in+            if l = [] then Empty else Leaf(h1,l)+          else newbranch h1 t1 h2 t2+    | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) ->+          if k land (b - 1) = p then+            if k land b = 0 then+              (match combine op z lf l with+                 Empty -> r | l' -> Branch(p,b,l',r))+            else+              (match combine op z lf r with+                 Empty -> l | r' -> Branch(p,b,l,r'))+          else+            newbranch k lf p br+    | (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) ->+          if k land (b - 1) = p then+            if k land b = 0 then+              (match combine op z l lf with+                Empty -> r | l' -> Branch(p,b,l',r))+            else+              (match combine op z r lf with+                 Empty -> l | r' -> Branch(p,b,l,r'))+          else+            newbranch p br k lf+    | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) ->+          if b1 < b2 then+            if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2+            else if p2 land b1 = 0 then+              (match combine op z l1 t2 with+                 Empty -> r1 | l -> Branch(p1,b1,l,r1))+            else+              (match combine op z r1 t2 with+                 Empty -> l1 | r -> Branch(p1,b1,l1,r))+          else if b2 < b1 then+            if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2+            else if p1 land b2 = 0 then+              (match combine op z t1 l2 with+                 Empty -> r2 | l -> Branch(p2,b2,l,r2))+            else+              (match combine op z t1 r2 with+                 Empty -> l2 | r -> Branch(p2,b2,l2,r))+          else if p1 = p2 then+           (match (combine op z l1 l2,combine op z r1 r2) with+              (Empty,r) -> r | (l,Empty) -> l | (l,r) -> Branch(p1,b1,l,r))+          else+            newbranch p1 t1 p2 t2 in+  (|->),combine;;+-}++-- -------------------------------------------------------------------------+-- Special case of point function.+-- -------------------------------------------------------------------------++(|=>) :: Ord k => k -> a -> Map k a+x |=> y = Map.singleton x y++-- -------------------------------------------------------------------------+-- Idiom for a mapping zipping domain and range lists.+-- -------------------------------------------------------------------------++(|->) :: Ord k => k -> a -> Map k a -> Map k a+(|->) = Map.insert++fpf :: Ord a => Map a b -> a -> Maybe b+fpf = flip Map.lookup++-- -------------------------------------------------------------------------+-- Grab an arbitrary element.+-- -------------------------------------------------------------------------++choose :: Map k a -> (k, a)+choose = Map.findMin++{-+(* ------------------------------------------------------------------------- *)+(* Install a (trivial) printer for finite partial functions.                 *)+(* ------------------------------------------------------------------------- *)++let print_fpf (f:('a,'b)func) = print_string "<func>";;++#install_printer print_fpf;;++(* ------------------------------------------------------------------------- *)+(* Related stuff for standard functions.                                     *)+(* ------------------------------------------------------------------------- *)++let valmod a y f x = if x = a then y else f(x);;++let undef x = failwith "undefined function";;++(* ------------------------------------------------------------------------- *)+(* Union-find algorithm.                                                     *)+(* ------------------------------------------------------------------------- *)++type ('a)pnode = Nonterminal of 'a | Terminal of 'a * int;;++type ('a)partition = Partition of ('a,('a)pnode)func;;++let rec terminus (Partition f as ptn) a =+  match (apply f a) with+    Nonterminal(b) -> terminus ptn b+  | Terminal(p,q) -> (p,q);;++let tryterminus ptn a =+  try terminus ptn a with Failure _ -> (a,1);;++let canonize ptn a = fst(tryterminus ptn a);;++let equivalent eqv a b = canonize eqv a = canonize eqv b;;++let equate (a,b) (Partition f as ptn) =+  let (a',na) = tryterminus ptn a+  and (b',nb) = tryterminus ptn b in+  Partition+   (if a' = b' then f else+    if na <= nb then+       itlist identity [a' |-> Nonterminal b'; b' |-> Terminal(b',na+nb)] f+    else+       itlist identity [b' |-> Nonterminal a'; a' |-> Terminal(a',na+nb)] f);;++let unequal = Partition undefined;;++let equated (Partition f) = dom f;;++(* ------------------------------------------------------------------------- *)+(* First number starting at n for which p succeeds.                          *)+(* ------------------------------------------------------------------------- *)++let rec first n p = if p(n) then n else first (n +/ Int 1) p;;+-}++-- | Try f with higher and higher values of n until it succeeds, or+-- optional maximum depth limit is exceeded.+{-+let rec deepen f n =+  try print_string "Searching with depth limit ";+      print_int n; print_newline(); f n+  with Failure _ -> deepen f (n + 1);;+-}+deepen :: (Depth -> Failing t) -> Depth -> Maybe Depth -> Failing (t, Depth)+deepen _ n (Just m) | n > m = Failure ["Exceeded maximum depth limit"]+deepen f n m =+    -- If no maximum depth limit is given print a trace of the+    -- levels tried.  The assumption is that we are running+    -- interactively.+    let n' = maybe (trace ("Searching with depth limit " ++ show n) n) (\_ -> n) m in+    case f n' of+      Failure _ -> deepen f (succ n) m+      Success x -> Success (x, n)++newtype Depth = Depth Int deriving (Eq, Ord, Show)++instance Enum Depth where+    toEnum = Depth+    fromEnum (Depth n) = n++instance Pretty Depth where+    pPrint = text . show++testLib :: Test+testLib = TestLabel "Lib" (TestList [test01])
+ src/Data/Logic/ATP/Lit.hs view
@@ -0,0 +1,202 @@+-- | 'IsLiteral' is a subclass of formulas that support negation and+-- have true and false elements.++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Logic.ATP.Lit+    ( IsLiteral(naiveNegate, foldNegation, foldLiteral')+    , (.~.), (¬), negate+    , negated+    , negative, positive+    , foldLiteral+    , JustLiteral+    , onatomsLiteral+    , overatomsLiteral+    , zipLiterals', zipLiterals+    , convertLiteral+    , convertToLiteral+    , precedenceLiteral+    , associativityLiteral+    , prettyLiteral+    , showLiteral+    -- * Instance+    , LFormula(T, F, Atom, Not)+    , Lit(L, lname)+    ) where++import Data.Data (Data)+import Data.Logic.ATP.Formulas (IsAtom, IsFormula(atomic, AtomOf, asBool, false, true), fromBool, overatoms, onatoms, prettyBool)+import Data.Logic.ATP.Pretty (Associativity(..), boolPrec, Doc, HasFixity(precedence, associativity), notPrec, Precedence, text)+import Data.Monoid ((<>))+import Data.Typeable (Typeable)+import Prelude hiding (negate, null)+import Text.PrettyPrint.HughesPJClass (maybeParens, Pretty(pPrint, pPrintPrec), PrettyLevel, prettyNormal)++-- | The class of formulas that can be negated.  Literals are the+-- building blocks of the clause and implicative normal forms.  They+-- support negation and must include true and false elements.+class IsFormula lit => IsLiteral lit where+    -- | Negate a formula in a naive fashion, the operators below+    -- prevent double negation.+    naiveNegate :: lit -> lit+    -- | Test whether a lit is negated or normal+    foldNegation :: (lit -> r) -- ^ called for normal formulas+                 -> (lit -> r) -- ^ called for negated formulas+                 -> lit -> r+    -- | This is the internal fold for literals, 'foldLiteral' below should+    -- normally be used, but its argument must be an instance of 'JustLiteral'.+    foldLiteral' :: (lit -> r) -- ^ Called for higher order formulas (non-literal)+                 -> (lit -> r) -- ^ Called for negated formulas+                 -> (Bool -> r) -- ^ Called for true and false formulas+                 -> (AtomOf lit -> r) -- ^ Called for atomic formulas+                 -> lit -> r++-- | Is this formula negated at the top level?+negated :: IsLiteral formula => formula -> Bool+negated = foldNegation (const False) (not . negated)++-- | Negate the formula, avoiding double negation+(.~.), (¬), negate :: IsLiteral formula => formula -> formula+(.~.) = foldNegation naiveNegate id+(¬) = (.~.)+negate = (.~.)+infix 6 .~., ¬++-- | Some operations on IsLiteral formulas+negative :: IsLiteral formula => formula -> Bool+negative = negated++positive :: IsLiteral formula => formula -> Bool+positive = not . negative++foldLiteral :: JustLiteral lit => (lit -> r) -> (Bool -> r) -> (AtomOf lit -> r) -> lit -> r+foldLiteral = foldLiteral' (error "JustLiteral failure")++-- | Class that indicates that a formula type *only* contains 'IsLiteral'+-- features - no combinations or quantifiers.+class IsLiteral formula => JustLiteral formula++-- | Combine two literals (internal version).+zipLiterals' :: (IsLiteral lit1, IsLiteral lit2) =>+                (lit1 -> lit2 -> Maybe r)+             -> (lit1 -> lit2 -> Maybe r)+             -> (Bool -> Bool -> Maybe r)+             -> (AtomOf lit1 -> AtomOf lit2 -> Maybe r)+             -> lit1 -> lit2 -> Maybe r+zipLiterals' ho neg tf at fm1 fm2 =+    foldLiteral' ho' neg' tf' at' fm1+    where+      ho' x1 = foldLiteral' (ho x1) (\ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) fm2+      neg' p1 = foldLiteral' (\ _ -> Nothing) (neg p1) (\ _ -> Nothing) (\ _ -> Nothing) fm2+      tf' x1 = foldLiteral' (\ _ -> Nothing) (\ _ -> Nothing) (tf x1) (\ _ -> Nothing) fm2+      at' a1 = foldLiteral' (\ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) (at a1) fm2++-- | Combine two literals.+zipLiterals :: (JustLiteral lit1, JustLiteral lit2) =>+               (lit1 -> lit2 -> Maybe r)+            -> (Bool -> Bool -> Maybe r)+            -> (AtomOf lit1 -> AtomOf lit2 -> Maybe r)+            -> lit1 -> lit2 -> Maybe r+zipLiterals neg tf at fm1 fm2 =+    foldLiteral neg' tf' at' fm1+    where+      neg' p1 = foldLiteral (neg p1) (\ _ -> Nothing) (\ _ -> Nothing) fm2+      tf' x1 = foldLiteral (\ _ -> Nothing) (tf x1) (\ _ -> Nothing) fm2+      at' a1 = foldLiteral (\ _ -> Nothing) (\ _ -> Nothing) (at a1) fm2++-- | Convert a 'JustLiteral' instance to any 'IsLiteral' instance.+convertLiteral :: (JustLiteral lit1, IsLiteral lit2) => (AtomOf lit1 -> AtomOf lit2) -> lit1 -> lit2+convertLiteral ca fm = foldLiteral (\fm' -> (.~.) (convertLiteral ca fm')) fromBool (atomic . ca) fm++-- | Convert any formula to a literal, passing non-IsLiteral+-- structures to the first argument (typically a call to error.)+convertToLiteral :: (IsLiteral formula, JustLiteral lit) =>+                    (formula -> lit) -> (AtomOf formula -> AtomOf lit) -> formula -> lit+convertToLiteral ho ca fm = foldLiteral' ho (\fm' -> (.~.) (convertToLiteral ho ca fm')) fromBool (atomic . ca) fm++precedenceLiteral :: JustLiteral lit => lit -> Precedence+precedenceLiteral = foldLiteral (const notPrec) (const boolPrec) precedence+associativityLiteral :: JustLiteral lit => lit -> Associativity+associativityLiteral = foldLiteral (const InfixA) (const InfixN) associativity++-- | Implementation of 'pPrint' for -- 'JustLiteral' types.+prettyLiteral :: JustLiteral lit => PrettyLevel -> Rational -> lit -> Doc+prettyLiteral l r lit =+    maybeParens (l > prettyNormal || r > precedence lit) (foldLiteral ne tf at lit)+    where+      ne p = text "¬" <> prettyLiteral l (precedence lit) p+      tf = prettyBool+      at a = pPrint a++showLiteral :: JustLiteral lit => lit -> String+showLiteral lit = foldLiteral ne tf at lit+    where+      ne p = "(.~.)(" ++ showLiteral p ++ ")"+      tf = show+      at = show++-- | Implementation of 'onatoms' for 'JustLiteral' types.+onatomsLiteral :: JustLiteral lit => (AtomOf lit -> AtomOf lit) -> lit -> lit+onatomsLiteral f fm =+    foldLiteral ne tf at fm+    where+      ne p = (.~.) (onatomsLiteral f p)+      tf = fromBool+      at x = atomic (f x)++-- | implementation of 'overatoms' for 'JustLiteral' types.+overatomsLiteral :: JustLiteral lit => (AtomOf lit -> r -> r) -> lit -> r -> r+overatomsLiteral f fm r0 =+        foldLiteral ne (const r0) (flip f r0) fm+        where+          ne fm' = overatomsLiteral f fm' r0++-- | Example of a 'JustLiteral' type.+data LFormula atom+    = F+    | T+    | Atom atom+    | Not (LFormula atom)+    deriving (Eq, Ord, Read, Show, Data, Typeable)++data Lit = L {lname :: String} deriving (Eq, Ord)++instance IsAtom atom => IsFormula (LFormula atom) where+    type AtomOf (LFormula atom) = atom+    asBool T = Just True+    asBool F = Just False+    asBool _ = Nothing+    true = T+    false = F+    atomic = Atom+    overatoms = overatomsLiteral+    onatoms = onatomsLiteral++instance (IsFormula (LFormula atom), Eq atom, Ord atom) => IsLiteral (LFormula atom) where+    naiveNegate = Not+    foldNegation normal inverted (Not x) = foldNegation inverted normal x+    foldNegation normal _ x = normal x+    foldLiteral' _ ne tf at lit =+        case lit of+          F -> tf False+          T -> tf True+          Atom a -> at a+          Not f -> ne f++instance IsAtom atom => JustLiteral (LFormula atom)++instance IsAtom atom => HasFixity (LFormula atom) where+    precedence = precedenceLiteral+    associativity = associativityLiteral++instance IsAtom atom => Pretty (LFormula atom) where+    pPrintPrec = prettyLiteral
+ src/Data/Logic/ATP/Meson.hs view
@@ -0,0 +1,743 @@+-- | Model elimination procedure (MESON version, based on Stickel's PTTP).+--+-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall #-}++module Data.Logic.ATP.Meson+    ( meson1+    , meson2+    , meson+    , testMeson+    ) where++import Control.Monad.State (execStateT)+import Data.Logic.ATP.Apply (HasApply(TermOf, PredOf), pApp)+import Data.Logic.ATP.FOL (generalize, IsFirstOrder)+import Data.Logic.ATP.Formulas (false, IsFormula(AtomOf))+import Data.Logic.ATP.Lib (Depth(Depth), deepen, Failing(Failure, Success), setAll, settryfind)+import Data.Logic.ATP.Lit ((.~.), JustLiteral, LFormula, negative)+import Data.Logic.ATP.Parser (fof)+import Data.Logic.ATP.Pretty (assertEqual', prettyShow, testEquals)+import Data.Logic.ATP.Prolog (PrologRule(Prolog), renamerule)+import Data.Logic.ATP.Prop ((.&.), (.|.), (.=>.), list_conj, PFormula, simpcnf)+import Data.Logic.ATP.Quantified (exists, for_all, IsQuantified(VarOf))+import Data.Logic.ATP.Resolution (davis_putnam_example_formula)+import Data.Logic.ATP.Skolem (askolemize, Formula, HasSkolem(SVarOf), pnf, runSkolem, SkolemT, simpdnf', specialize, toSkolem)+import Data.Logic.ATP.Tableaux (K(K), tab)+import Data.Logic.ATP.Term (fApp, IsTerm(FunOf, TVarOf), vt)+import Data.Logic.ATP.Unif (Unify, unify_literals)+import Data.Map.Strict as Map+import Data.Set as Set+import Test.HUnit++test03 :: Test+test03 = let fm = [fof| ∀a. ¬(P(a)∧(∀y. (∀z. Q(y)∨R(z))∧¬P(a))) |] in+         $(testEquals "TAB 1") (Success ((K 2, Map.empty),Depth 2)) (tab Nothing fm)++test04 :: Test+test04 = let fm = [fof| ∀a. ¬(P(a)∧¬P(a)∧(∀y z. Q(y)∨R(z))) |] in+         $(testEquals "TAB 2") (Success ((K 0, Map.empty),Depth 0)) (tab Nothing fm)++        {- fm3 = [fof| ¬p ∧ (p ∨ q) ∧ (r ∨ s) ∧ (¬q ∨ t ∨ u) ∧+                    (¬r ∨ ¬t) ∧ (¬r ∨ ¬u) ∧ (¬q ∨ v ∨ w) ∧+               (¬s ∨ ¬v) ∧ (¬s ∨ ¬w) |] -}++{-+START_INTERACTIVE;;+tab <<forall a. ~(P(a) /\ (forall y z. Q(y) \/ R(z)) /\ ~P(a))>>;;++tab <<forall a. ~(P(a) /\ ~P(a) /\ (forall y z. Q(y) \/ R(z)))>>;;++(* ------------------------------------------------------------------------- *)+(* The interesting example where tableaux connections make the proof longer. *)+(* Unfortuntely this gets hammered by normalization first...                 *)+(* ------------------------------------------------------------------------- *)++tab <<~p /\ (p \/ q) /\ (r \/ s) /\ (~q \/ t \/ u) /\+      (~r \/ ~t) /\ (~r \/ ~u) /\ (~q \/ v \/ w) /\+      (~s \/ ~v) /\ (~s \/ ~w) ==> false>>;;+END_INTERACTIVE;;+-}+-- -------------------------------------------------------------------------+-- Example of naivety of tableau prover.+-- -------------------------------------------------------------------------++test05 :: Test+test05 = $(testEquals "test001") (Success ((K 0, Map.empty), Depth 0))+         (tab Nothing [fof| ¬p∧(p∨q)∧(r∨s)∧(¬q∨t∨u)∧(¬r∨¬t)∧(¬r∨¬u)∧(¬q∨v∨w)∧(¬s∨¬v)∧(¬s∨¬w)⇒⊥|])++test01 :: Test+test01 = TestLabel "Meson 1" $ TestCase $ assertEqual' "meson dp example (p. 220)" expected input+    where input = runSkolem (meson (Just (Depth 10)) (davis_putnam_example_formula :: Formula))+          expected :: Set (Failing Depth)+          expected = Set.singleton (Success (Depth 8))++test06 :: Test+test06 = $(testEquals "meson dp example, step 1 (p. 220)") [fof| ∃x y. (∀z. (F(x,y)⇒F(y,z)∧F(z,z))∧(F(x,y)∧G(x,y)⇒G(x,z)∧G(z,z))) |]+           davis_putnam_example_formula++test02 :: Test+test02 =+    TestLabel "Meson 2" $+    TestList [TestCase (assertEqual' "meson dp example, step 2 (p. 220)"+                                    (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])))))))+                                    (generalize davis_putnam_example_formula)),+              TestCase (assertEqual' "meson dp example, step 3 (p. 220)"+                                    ((.~.)(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)+                                    ((.~.) (generalize davis_putnam_example_formula))),+              TestCase (assertEqual' "meson dp example, step 4 (p. 220)"+                                    (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]]))))+                                    (runSkolem (askolemize ((.~.) (generalize davis_putnam_example_formula))) :: Formula)),+              TestCase (assertEqual "meson dp example, step 5 (p. 220)"+                                    (Set.map (Set.map prettyShow)+                                     (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 prettyShow) (simpdnf' (runSkolem (askolemize ((.~.) (generalize davis_putnam_example_formula))) :: Formula) :: Set (Set Formula)))),+              TestCase (assertEqual "meson dp example, step 6 (p. 220)"+                                    (Set.map prettyShow+                                     (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 prettyShow ((Set.map list_conj (simpdnf' (runSkolem (askolemize ((.~.) (generalize davis_putnam_example_formula)))))) :: Set (Formula))))]+    where f = pApp "F"+          g = pApp "G"+          sk1 = fApp (toSkolem "z" 1)+          x = vt "x"+          y = vt "y"+          z = vt "z"++{-+askolemize (simpdnf (generalize davis_putnam_example_formula)) ->+ <<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)))>>+-}++{-+START_INTERACTIVE;;+tab <<forall a. ~(P(a) /\ (forall y z. Q(y) \/ R(z)) /\ ~P(a))>>;;++tab <<forall a. ~(P(a) /\ ~P(a) /\ (forall y z. Q(y) \/ R(z)))>>;;++-- -------------------------------------------------------------------------+-- The interesting example where tableaux connections make the proof longer.+-- Unfortuntely this gets hammered by normalization first...+-- -------------------------------------------------------------------------++tab <<~p /\ (p \/ q) /\ (r \/ s) /\ (~q \/ t \/ u) /\+      (~r \/ ~t) /\ (~r \/ ~u) /\ (~q \/ v \/ w) /\+      (~s \/ ~v) /\ (~s \/ ~w) ==> false>>;;+END_INTERACTIVE;;+-}++-- -------------------------------------------------------------------------+-- Generation of contrapositives.+-- -------------------------------------------------------------------------++contrapositives :: (JustLiteral lit, Ord lit) => Set lit -> Set (PrologRule lit)+contrapositives cls =+    if setAll negative cls then Set.insert (Prolog (Set.map (.~.) cls) false) base else base+    where base = Set.map (\ c -> (Prolog (Set.map (.~.) (Set.delete c cls)) c)) cls++-- -------------------------------------------------------------------------+-- The core of MESON: ancestor unification or Prolog-style extension.+-- -------------------------------------------------------------------------++mexpand1 :: (JustLiteral lit, Ord lit,+             HasApply atom, IsTerm term, Unify atom v term,+             atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+           Set (PrologRule lit)+        -> Set lit+        -> lit+        -> ((Map v term, Int, Int) -> Failing (Map v term, Int, Int))+        -> (Map v term, Int, Int)+        -> Failing (Map v term, Int, Int)+mexpand1 rules ancestors g cont (env,n,k) =+    if fromEnum n < 0+    then Failure ["Too deep"]+    else case settryfind doAncestor ancestors of+           Success a -> Success a+           Failure _ -> settryfind doRule rules+    where+      doAncestor a =+          do mp <- execStateT (unify_literals g ((.~.) a)) env+             cont (mp, n, k)+      doRule rule =+          do mp <- execStateT (unify_literals g c) env+             mexpand1' (mp, fromEnum n - Set.size asm, k')+          where+            mexpand1' = Set.fold (mexpand1 rules (Set.insert g ancestors)) cont asm+            (Prolog asm c, k') = renamerule k rule++-- -------------------------------------------------------------------------+-- Full MESON procedure.+-- -------------------------------------------------------------------------++puremeson1 :: forall fof atom term v function.+              (IsFirstOrder fof, Unify atom v term, Ord fof,+               atom ~ AtomOf fof, term ~ TermOf atom, function ~ FunOf term,+               v ~ VarOf fof, v ~ TVarOf term) =>+              Maybe Depth -> fof -> Failing Depth+puremeson1 maxdl fm =+    snd <$> deepen f (Depth 0) maxdl+    where+      f :: Depth -> Failing (Map v term, Int, Int)+      f n = mexpand1 rules (Set.empty :: Set (LFormula atom)) false return (Map.empty, fromEnum n, 0)+      rules = Set.fold (Set.union . contrapositives) Set.empty cls+      (cls :: Set (Set (LFormula atom))) = simpcnf id (specialize id (pnf fm) :: PFormula atom)++meson1 :: forall m fof atom predicate term function v.+          (IsFirstOrder fof, Unify atom (VarOf fof) (TermOf (atom)), Ord fof, HasSkolem function, Monad m,+           atom ~ AtomOf fof, term ~ TermOf atom, predicate ~ PredOf atom, function ~ FunOf term, v ~ VarOf fof, v ~ SVarOf function) =>+          Maybe Depth -> fof -> SkolemT m function (Set (Failing Depth))+meson1 maxdl fm =+    askolemize ((.~.)(generalize fm)) >>=+    return . Set.map (puremeson1 maxdl . list_conj) . (simpdnf' :: fof -> Set (Set fof))++-- -------------------------------------------------------------------------+-- With repetition checking and divide-and-conquer search.+-- -------------------------------------------------------------------------++equal :: (JustLiteral lit, HasApply atom, Unify atom v term, IsTerm term,+          atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+         Map v term -> lit -> lit -> Bool+equal env fm1 fm2 =+    case execStateT (unify_literals fm1 fm2) env of+      Success env' | env == env' -> True+      _ -> False++expand2 :: (Set lit ->+            ((Map v term, Int, Int) -> Failing (Map v term, Int, Int)) ->+            (Map v term, Int, Int) -> Failing (Map v term, Int, Int))+        -> Set lit+        -> Int+        -> Set lit+        -> Int+        -> Int+        -> ((Map v term, Int, Int) -> Failing (Map v term, Int, Int))+        -> Map v term+        -> Int+        -> Failing (Map v term, Int, Int)+expand2 expfn goals1 n1 goals2 n2 n3 cont env k =+    expfn goals1 (\(e1,r1,k1) ->+                      expfn goals2 (\(e2,r2,k2) ->+                                        if n2 + n1 <= n3 + r2 then Failure ["pair"] else cont (e2,r2,k2))+                                   (e1,n2+r1,k1))+                 (env,n1,k)++mexpand2 :: (JustLiteral lit, Ord lit, HasApply atom, IsTerm term, Unify atom v term,+             atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+           Set (PrologRule lit)+        -> Set lit+        -> lit+        -> ((Map v term, Int, Int) -> Failing (Map v term, Int, Int))+        -> (Map v term, Int, Int)+        -> Failing (Map v term, Int, Int)+mexpand2 rules ancestors g cont (env,n,k) =+    if fromEnum n < 0+    then Failure ["Too deep"]+    else if any (equal env g) ancestors+         then Failure ["repetition"]+         else case settryfind doAncestor ancestors of+                Success a -> Success a+                Failure _ -> settryfind doRule rules+    where+      doAncestor a =+          do mp <- execStateT (unify_literals g ((.~.) a)) env+             cont (mp, n, k)+      doRule rule =+          do mp <- execStateT (unify_literals g c) env+             mexpand2' (mp, fromEnum n - Set.size asm, k')+          where+            mexpand2' = mexpands rules (Set.insert g ancestors) asm cont+            (Prolog asm c, k') = renamerule k rule++mexpands :: (JustLiteral lit, Ord lit, HasApply atom, Unify atom v term, IsTerm term,+             atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+            Set (PrologRule lit)+         -> Set lit+         -> Set lit+         -> ((Map v term, Int, Int) -> Failing (Map v term, Int, Int))+         -> (Map v term, Int, Int)+         -> Failing (Map v term, Int, Int)+mexpands rules ancestors gs cont (env,n,k) =+    if fromEnum n < 0+    then Failure ["Too deep"]+    else let m = Set.size gs in+         if m <= 1+         then Set.foldr (mexpand2 rules ancestors) cont gs (env,n,k)+         else let n1 = n `div` 2+                  n2 = n - n1 in+              let (goals1, goals2) = setSplitAt (m `div` 2) gs in+              let expfn = expand2 (mexpands rules ancestors) in+              case expfn goals1 n1 goals2 n2 (-1) cont env k of+                Success r -> Success r+                Failure _ -> expfn goals2 n1 goals1 n2 n1 cont env k++setSplitAt :: Ord a => Int -> Set a -> (Set a, Set a)+setSplitAt n s = go n (mempty, s)+    where+      go 0 (s1, s2) = (s1, s2)+      go i (s1, s2) = case Set.minView s2 of+                         Nothing -> (s1, s2)+                         Just (x, s2') -> go (i - 1) (Set.insert x s1, s2')++puremeson2 :: forall fof atom term v.+             (atom ~ AtomOf fof, term ~ TermOf atom, v ~ VarOf fof, v ~ TVarOf term,+              IsFirstOrder fof,+              Unify atom v term, Ord fof+             ) => Maybe Depth -> fof -> Failing Depth+puremeson2 maxdl fm =+    snd <$> deepen f (Depth 0) maxdl+    where+      f :: Depth -> Failing (Map v term, Int, Int)+      f n = mexpand2 rules (Set.empty :: Set (LFormula atom)) false return (Map.empty, fromEnum n, 0)+      rules = Set.fold (Set.union . contrapositives) Set.empty cls+      (cls :: Set (Set (LFormula atom))) = simpcnf id (specialize id (pnf fm) :: PFormula atom)++meson2 :: forall m fof atom term function v.+          (IsFirstOrder fof, Unify atom v term, Ord fof,+           HasSkolem function, Monad m,+           atom ~ AtomOf fof, term ~ TermOf atom, function ~ FunOf term, v ~ VarOf fof, v ~ SVarOf function) =>+          Maybe Depth -> fof -> SkolemT m function (Set (Failing Depth))+meson2 maxdl fm =+    askolemize ((.~.)(generalize fm)) >>=+    return . Set.map (puremeson2 maxdl . list_conj) . (simpdnf' :: fof -> Set (Set fof))++meson :: (IsFirstOrder fof, Unify atom v term, HasSkolem function, Monad m, Ord fof,+          atom ~ AtomOf fof, term ~ TermOf atom, function ~ FunOf term, v ~ VarOf fof, v ~ SVarOf function) =>+         Maybe Depth -> fof -> SkolemT m function (Set (Failing Depth))+meson = meson2++{-+-- -------------------------------------------------------------------------+-- The Los problem (depth 20) and the Steamroller (depth 53) --- lengthier.+-- -------------------------------------------------------------------------++START_INTERACTIVE;;+{- ***********++let los = meson+ <<(forall x y z. P(x,y) ==> P(y,z) ==> P(x,z)) /\+   (forall x y z. Q(x,y) ==> Q(y,z) ==> Q(x,z)) /\+   (forall x y. Q(x,y) ==> Q(y,x)) /\+   (forall x y. P(x,y) \/ Q(x,y))+   ==> (forall x y. P(x,y)) \/ (forall x y. Q(x,y))>>;;++let steamroller = meson+ <<((forall x. P1(x) ==> P0(x)) /\ (exists x. P1(x))) /\+   ((forall x. P2(x) ==> P0(x)) /\ (exists x. P2(x))) /\+   ((forall x. P3(x) ==> P0(x)) /\ (exists x. P3(x))) /\+   ((forall x. P4(x) ==> P0(x)) /\ (exists x. P4(x))) /\+   ((forall x. P5(x) ==> P0(x)) /\ (exists x. P5(x))) /\+   ((exists x. Q1(x)) /\ (forall x. Q1(x) ==> Q0(x))) /\+   (forall x. P0(x)+              ==> (forall y. Q0(y) ==> R(x,y)) \/+                  ((forall y. P0(y) /\ S0(y,x) /\+                              (exists z. Q0(z) /\ R(y,z))+                              ==> R(x,y)))) /\+   (forall x y. P3(y) /\ (P5(x) \/ P4(x)) ==> S0(x,y)) /\+   (forall x y. P3(x) /\ P2(y) ==> S0(x,y)) /\+   (forall x y. P2(x) /\ P1(y) ==> S0(x,y)) /\+   (forall x y. P1(x) /\ (P2(y) \/ Q1(y)) ==> ~(R(x,y))) /\+   (forall x y. P3(x) /\ P4(y) ==> R(x,y)) /\+   (forall x y. P3(x) /\ P5(y) ==> ~(R(x,y))) /\+   (forall x. (P4(x) \/ P5(x)) ==> exists y. Q0(y) /\ R(x,y))+   ==> exists x y. P0(x) /\ P0(y) /\+                   exists z. Q1(z) /\ R(y,z) /\ R(x,y)>>;;++*************** -}+++-- -------------------------------------------------------------------------+-- Test it.+-- -------------------------------------------------------------------------++let prop_1 = time meson+ <<p ==> q <=> ~q ==> ~p>>;;++let prop_2 = time meson+ <<~ ~p <=> p>>;;++let prop_3 = time meson+ <<~(p ==> q) ==> q ==> p>>;;++let prop_4 = time meson+ <<~p ==> q <=> ~q ==> p>>;;++let prop_5 = time meson+ <<(p \/ q ==> p \/ r) ==> p \/ (q ==> r)>>;;++let prop_6 = time meson+ <<p \/ ~p>>;;++let prop_7 = time meson+ <<p \/ ~ ~ ~p>>;;++let prop_8 = time meson+ <<((p ==> q) ==> p) ==> p>>;;++let prop_9 = time meson+ <<(p \/ q) /\ (~p \/ q) /\ (p \/ ~q) ==> ~(~q \/ ~q)>>;;++let prop_10 = time meson+ <<(q ==> r) /\ (r ==> p /\ q) /\ (p ==> q /\ r) ==> (p <=> q)>>;;++let prop_11 = time meson+ <<p <=> p>>;;++let prop_12 = time meson+ <<((p <=> q) <=> r) <=> (p <=> (q <=> r))>>;;++let prop_13 = time meson+ <<p \/ q /\ r <=> (p \/ q) /\ (p \/ r)>>;;++let prop_14 = time meson+ <<(p <=> q) <=> (q \/ ~p) /\ (~q \/ p)>>;;++let prop_15 = time meson+ <<p ==> q <=> ~p \/ q>>;;++let prop_16 = time meson+ <<(p ==> q) \/ (q ==> p)>>;;++let prop_17 = time meson+ <<p /\ (q ==> r) ==> s <=> (~p \/ q \/ s) /\ (~p \/ ~r \/ s)>>;;++-- -------------------------------------------------------------------------+-- Monadic Predicate Logic.+-- -------------------------------------------------------------------------++let p18 = time meson+ <<exists y. forall x. P(y) ==> P(x)>>;;++let p19 = time meson+ <<exists x. forall y z. (P(y) ==> Q(z)) ==> P(x) ==> Q(x)>>;;++let p20 = time meson+ <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w)) ==>+   (exists x y. P(x) /\ Q(y)) ==>+   (exists z. R(z))>>;;++let p21 = time meson+ <<(exists x. P ==> Q(x)) /\ (exists x. Q(x) ==> P)+   ==> (exists x. P <=> Q(x))>>;;++let p22 = time meson+ <<(forall x. P <=> Q(x)) ==> (P <=> (forall x. Q(x)))>>;;++let p23 = time meson+ <<(forall x. P \/ Q(x)) <=> P \/ (forall x. Q(x))>>;;++let p24 = time meson+ <<~(exists x. U(x) /\ Q(x)) /\+   (forall x. P(x) ==> Q(x) \/ R(x)) /\+   ~(exists x. P(x) ==> (exists x. Q(x))) /\+   (forall x. Q(x) /\ R(x) ==> U(x)) ==>+   (exists x. P(x) /\ R(x))>>;;++let p25 = time meson+ <<(exists x. P(x)) /\+   (forall x. U(x) ==> ~G(x) /\ R(x)) /\+   (forall x. P(x) ==> G(x) /\ U(x)) /\+   ((forall x. P(x) ==> Q(x)) \/ (exists x. Q(x) /\ P(x))) ==>+   (exists x. Q(x) /\ P(x))>>;;++let p26 = time meson+ <<((exists x. P(x)) <=> (exists x. Q(x))) /\+   (forall x y. P(x) /\ Q(y) ==> (R(x) <=> U(y))) ==>+   ((forall x. P(x) ==> R(x)) <=> (forall x. Q(x) ==> U(x)))>>;;++let p27 = time meson+ <<(exists x. P(x) /\ ~Q(x)) /\+   (forall x. P(x) ==> R(x)) /\+   (forall x. U(x) /\ V(x) ==> P(x)) /\+   (exists x. R(x) /\ ~Q(x)) ==>+   (forall x. U(x) ==> ~R(x)) ==>+   (forall x. U(x) ==> ~V(x))>>;;++let p28 = time meson+ <<(forall x. P(x) ==> (forall x. Q(x))) /\+   ((forall x. Q(x) \/ R(x)) ==> (exists x. Q(x) /\ R(x))) /\+   ((exists x. R(x)) ==> (forall x. L(x) ==> M(x))) ==>+   (forall x. P(x) /\ L(x) ==> M(x))>>;;++let p29 = time meson+ <<(exists x. P(x)) /\ (exists x. G(x)) ==>+   ((forall x. P(x) ==> H(x)) /\ (forall x. G(x) ==> J(x)) <=>+    (forall x y. P(x) /\ G(y) ==> H(x) /\ J(y)))>>;;++let p30 = time meson+ <<(forall x. P(x) \/ G(x) ==> ~H(x)) /\ (forall x. (G(x) ==> ~U(x)) ==>+     P(x) /\ H(x)) ==>+   (forall x. U(x))>>;;++let p31 = time meson+ <<~(exists x. P(x) /\ (G(x) \/ H(x))) /\ (exists x. Q(x) /\ P(x)) /\+   (forall x. ~H(x) ==> J(x)) ==>+   (exists x. Q(x) /\ J(x))>>;;++let p32 = time meson+ <<(forall x. P(x) /\ (G(x) \/ H(x)) ==> Q(x)) /\+   (forall x. Q(x) /\ H(x) ==> J(x)) /\+   (forall x. R(x) ==> H(x)) ==>+   (forall x. P(x) /\ R(x) ==> J(x))>>;;++let p33 = time meson+ <<(forall x. P(a) /\ (P(x) ==> P(b)) ==> P(c)) <=>+   (forall x. P(a) ==> P(x) \/ P(c)) /\ (P(a) ==> P(b) ==> P(c))>>;;++let p34 = time meson+ <<((exists x. forall y. P(x) <=> P(y)) <=>+    ((exists x. Q(x)) <=> (forall y. Q(y)))) <=>+   ((exists x. forall y. Q(x) <=> Q(y)) <=>+    ((exists x. P(x)) <=> (forall y. P(y))))>>;;++let p35 = time meson+ <<exists x y. P(x,y) ==> (forall x y. P(x,y))>>;;++-- -------------------------------------------------------------------------+--  Full predicate logic (without Identity and Functions)+-- -------------------------------------------------------------------------++let p36 = time meson+ <<(forall x. exists y. P(x,y)) /\+   (forall x. exists y. G(x,y)) /\+   (forall x y. P(x,y) \/ G(x,y)+   ==> (forall z. P(y,z) \/ G(y,z) ==> H(x,z)))+       ==> (forall x. exists y. H(x,y))>>;;++let p37 = time meson+ <<(forall z.+     exists w. forall x. exists y. (P(x,z) ==> P(y,w)) /\ P(y,z) /\+     (P(y,w) ==> (exists u. Q(u,w)))) /\+   (forall x z. ~P(x,z) ==> (exists y. Q(y,z))) /\+   ((exists x y. Q(x,y)) ==> (forall x. R(x,x))) ==>+   (forall x. exists y. R(x,y))>>;;++let p38 = time meson+ <<(forall x.+     P(a) /\ (P(x) ==> (exists y. P(y) /\ R(x,y))) ==>+     (exists z w. P(z) /\ R(x,w) /\ R(w,z))) <=>+   (forall x.+     (~P(a) \/ P(x) \/ (exists z w. P(z) /\ R(x,w) /\ R(w,z))) /\+     (~P(a) \/ ~(exists y. P(y) /\ R(x,y)) \/+     (exists z w. P(z) /\ R(x,w) /\ R(w,z))))>>;;++let p39 = time meson+ <<~(exists x. forall y. P(y,x) <=> ~P(y,y))>>;;++let p40 = time meson+ <<(exists y. forall x. P(x,y) <=> P(x,x))+  ==> ~(forall x. exists y. forall z. P(z,y) <=> ~P(z,x))>>;;++let p41 = time meson+ <<(forall z. exists y. forall x. P(x,y) <=> P(x,z) /\ ~P(x,x))+  ==> ~(exists z. forall x. P(x,z))>>;;++let p42 = time meson+ <<~(exists y. forall x. P(x,y) <=> ~(exists z. P(x,z) /\ P(z,x)))>>;;++let p43 = time meson+ <<(forall x y. Q(x,y) <=> forall z. P(z,x) <=> P(z,y))+   ==> forall x y. Q(x,y) <=> Q(y,x)>>;;++let p44 = time meson+ <<(forall x. P(x) ==> (exists y. G(y) /\ H(x,y)) /\+   (exists y. G(y) /\ ~H(x,y))) /\+   (exists x. J(x) /\ (forall y. G(y) ==> H(x,y))) ==>+   (exists x. J(x) /\ ~P(x))>>;;++let p45 = time meson+ <<(forall x.+     P(x) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y)) ==>+       (forall y. G(y) /\ H(x,y) ==> R(y))) /\+   ~(exists y. L(y) /\ R(y)) /\+   (exists x. P(x) /\ (forall y. H(x,y) ==>+     L(y)) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y))) ==>+   (exists x. P(x) /\ ~(exists y. G(y) /\ H(x,y)))>>;;++let p46 = time meson+ <<(forall x. P(x) /\ (forall y. P(y) /\ H(y,x) ==> G(y)) ==> G(x)) /\+   ((exists x. P(x) /\ ~G(x)) ==>+    (exists x. P(x) /\ ~G(x) /\+               (forall y. P(y) /\ ~G(y) ==> J(x,y)))) /\+   (forall x y. P(x) /\ P(y) /\ H(x,y) ==> ~J(y,x)) ==>+   (forall x. P(x) ==> G(x))>>;;++-- -------------------------------------------------------------------------+-- Example from Manthey and Bry, CADE-9.+-- -------------------------------------------------------------------------++let p55 = time meson+ <<lives(agatha) /\ lives(butler) /\ lives(charles) /\+   (killed(agatha,agatha) \/ killed(butler,agatha) \/+    killed(charles,agatha)) /\+   (forall x y. killed(x,y) ==> hates(x,y) /\ ~richer(x,y)) /\+   (forall x. hates(agatha,x) ==> ~hates(charles,x)) /\+   (hates(agatha,agatha) /\ hates(agatha,charles)) /\+   (forall x. lives(x) /\ ~richer(x,agatha) ==> hates(butler,x)) /\+   (forall x. hates(agatha,x) ==> hates(butler,x)) /\+   (forall x. ~hates(x,agatha) \/ ~hates(x,butler) \/ ~hates(x,charles))+   ==> killed(agatha,agatha) /\+       ~killed(butler,agatha) /\+       ~killed(charles,agatha)>>;;++let p57 = time meson+ <<P(f((a),b),f(b,c)) /\+  P(f(b,c),f(a,c)) /\+  (forall (x) y z. P(x,y) /\ P(y,z) ==> P(x,z))+  ==> P(f(a,b),f(a,c))>>;;++-- -------------------------------------------------------------------------+-- See info-hol, circa 1500.+-- -------------------------------------------------------------------------++let p58 = time meson+ <<forall P Q R. forall x. exists v. exists w. forall y. forall z.+    ((P(x) /\ Q(y)) ==> ((P(v) \/ R(w))  /\ (R(z) ==> Q(v))))>>;;++let p59 = time meson+ <<(forall x. P(x) <=> ~P(f(x))) ==> (exists x. P(x) /\ ~P(f(x)))>>;;++let p60 = time meson+ <<forall x. P(x,f(x)) <=>+            exists y. (forall z. P(z,y) ==> P(z,f(x))) /\ P(x,y)>>;;++-- -------------------------------------------------------------------------+-- From Gilmore's classic paper.+-- -------------------------------------------------------------------------++{- ** Amazingly, this still seems non-trivial... in HOL it works at depth 45!++let gilmore_1 = time meson+ <<exists x. forall y z.+      ((F(y) ==> G(y)) <=> F(x)) /\+      ((F(y) ==> H(y)) <=> G(x)) /\+      (((F(y) ==> G(y)) ==> H(y)) <=> H(x))+      ==> F(z) /\ G(z) /\ H(z)>>;;++ ** -}++{- ** This is not valid, according to Gilmore++let gilmore_2 = time meson+ <<exists x y. forall z.+        (F(x,z) <=> F(z,y)) /\ (F(z,y) <=> F(z,z)) /\ (F(x,y) <=> F(y,x))+        ==> (F(x,y) <=> F(x,z))>>;;++ ** -}++let gilmore_3 = time meson+ <<exists x. forall y z.+        ((F(y,z) ==> (G(y) ==> H(x))) ==> F(x,x)) /\+        ((F(z,x) ==> G(x)) ==> H(z)) /\+        F(x,y)+        ==> F(z,z)>>;;++let gilmore_4 = time meson+ <<exists x y. forall z.+        (F(x,y) ==> F(y,z) /\ F(z,z)) /\+        (F(x,y) /\ G(x,y) ==> G(x,z) /\ G(z,z))>>;;++let gilmore_5 = time meson+ <<(forall x. exists y. F(x,y) \/ F(y,x)) /\+   (forall x y. F(y,x) ==> F(y,y))+   ==> exists z. F(z,z)>>;;++let gilmore_6 = time meson+ <<forall x. exists y.+        (exists u. forall v. F(u,x) ==> G(v,u) /\ G(u,x))+        ==> (exists u. forall v. F(u,y) ==> G(v,u) /\ G(u,y)) \/+            (forall u v. exists w. G(v,u) \/ H(w,y,u) ==> G(u,w))>>;;++let gilmore_7 = time meson+ <<(forall x. K(x) ==> exists y. L(y) /\ (F(x,y) ==> G(x,y))) /\+   (exists z. K(z) /\ forall u. L(u) ==> F(z,u))+   ==> exists v w. K(v) /\ L(w) /\ G(v,w)>>;;++let gilmore_8 = time meson+ <<exists x. forall y z.+        ((F(y,z) ==> (G(y) ==> (forall u. exists v. H(u,v,x)))) ==> F(x,x)) /\+        ((F(z,x) ==> G(x)) ==> (forall u. exists v. H(u,v,z))) /\+        F(x,y)+        ==> F(z,z)>>;;++{- ** This is still a very hard problem++let gilmore_9 = time meson+ <<forall x. exists y. forall z.+        ((forall u. exists v. F(y,u,v) /\ G(y,u) /\ ~H(y,x))+          ==> (forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z))+             ==> (forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y))) /\+        ((forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y))+         ==> ~(forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z))+             ==> (forall u. exists v. F(y,u,v) /\ G(y,u) /\ ~H(y,x)) /\+                 (forall u. exists v. F(z,u,v) /\ G(y,u) /\ ~H(z,y)))>>;;++ ** -}++-- -------------------------------------------------------------------------+-- Translation of Gilmore procedure using separate definitions.+-- -------------------------------------------------------------------------++let gilmore_9a = time meson+ <<(forall x y. P(x,y) <=>+                forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y))+   ==> forall x. exists y. forall z.+             (P(y,x) ==> (P(x,z) ==> P(x,y))) /\+             (P(x,y) ==> (~P(x,z) ==> P(y,x) /\ P(z,y)))>>;;++-- -------------------------------------------------------------------------+-- Example from Davis-Putnam papers where Gilmore procedure is poor.+-- -------------------------------------------------------------------------++let davis_putnam_example = time meson+ <<exists x. exists y. forall z.+        (F(x,y) ==> (F(y,z) /\ F(z,z))) /\+        ((F(x,y) /\ G(x,y)) ==> (G(x,z) /\ G(z,z)))>>;;++-- -------------------------------------------------------------------------+-- The "connections make things worse" example once again.+-- -------------------------------------------------------------------------++meson <<~p /\ (p \/ q) /\ (r \/ s) /\ (~q \/ t \/ u) /\+        (~r \/ ~t) /\ (~r \/ ~u) /\ (~q \/ v \/ w) /\+        (~s \/ ~v) /\ (~s \/ ~w) ==> false>>;;+END_INTERACTIVE;;+-}++testMeson :: Test+testMeson = TestLabel "Meson" (TestList [test03, test04, test05, test01, test06, test02])
+ src/Data/Logic/ATP/Parser.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE CPP, NoMonomorphismRestriction, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, TemplateHaskell, TypeFamilies #-}+module Data.Logic.ATP.Parser where++-- Parsing expressions and statements+-- https://wiki.haskell.org/Parsing_expressions_and_statements++import Control.Monad.Identity+import Data.Char (isSpace)+import Data.List (nub)+import Data.String (fromString)+import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Text.Parsec+import Text.Parsec.Error+import Text.Parsec.Expr+import Text.Parsec.Token+import Text.Parsec.Language+import Text.PrettyPrint.HughesPJClass (Pretty(pPrint), text)++import Data.Logic.ATP.Apply+import Data.Logic.ATP.Equate+import Data.Logic.ATP.Formulas+import Data.Logic.ATP.Lit+import Data.Logic.ATP.Prop+import Data.Logic.ATP.Quantified+import Data.Logic.ATP.Skolem+import Data.Logic.ATP.Term++instance Pretty ParseError where+    pPrint = text . show++instance Pretty Message where+    pPrint (SysUnExpect s) = text ("SysUnExpect " ++ show s)+    pPrint (UnExpect s) = text ("UnExpect " ++ show s)+    pPrint (Expect s) = text ("Expect " ++ show s)+    pPrint (Message s) = text ("Message " ++ show s)++-- | QuasiQuote for a first order formula.  Loading this symbol into the interpreter+-- and setting -XQuasiQuotes lets you type expressions like [fof| ∃ x. p(x) |]+fof :: QuasiQuoter+fof = QuasiQuoter+    { quoteExp = \str -> [| (either (error . show) id . parseFOL) str :: Formula |]+    , quoteType = error "fof does not implement quoteType"+    , quotePat  = error "fof does not implement quotePat"+    , quoteDec  = error "fof does not implement quoteDec"+    }++-- | QuasiQuote for a propositional formula.  Exactly like fof, but no quantifiers.+pf :: QuasiQuoter+pf = QuasiQuoter+    { quoteExp = \str -> [| (either (error . show) id . parsePL) str :: PFormula EqAtom |]+    , quoteType = error "pf does not implement quoteType"+    , quotePat  = error "pf does not implement quotePat"+    , quoteDec  = error "pf does not implement quoteDec"+    }++-- | QuasiQuote for a propositional formula.  Exactly like fof, but no quantifiers.+lit :: QuasiQuoter+lit = QuasiQuoter+    { quoteExp = \str -> [| (either (error . show) id . parseLit) str :: LFormula EqAtom |]+    , quoteType = error "pf does not implement quoteType"+    , quotePat  = error "pf does not implement quotePat"+    , quoteDec  = error "pf does not implement quoteDec"+    }++-- | QuasiQuote for a propositional formula.  Exactly like fof, but no quantifiers.+term :: QuasiQuoter+term = QuasiQuoter+    { quoteExp = \str -> [| (either (error . show) id . parseFOLTerm) str :: FTerm |]+    , quoteType = error "term does not implement quoteType"+    , quotePat  = error "term does not implement quotePat"+    , quoteDec  = error "term does not implement quoteDec"+    }++#if 0+instance Read PrologRule where+   readsPrec _n str = [(parseProlog str,"")]++instance Read Formula where+   readsPrec _n str = [(parseFOL str,"")]++instance Read (PFormula EqAtom) where+   readsPrec _n str = [(parsePL str,"")]++parseProlog :: forall s. Stream s Identity Char => s -> PrologRule+parseProlog str = either (error . show) id $ parse prologparser "" str+#endif+parseFOL :: Stream String Identity Char => String -> Either ParseError Formula+parseFOL str = parse folparser "" (dropWhile isSpace str)+parsePL :: Stream String Identity Char => String -> Either ParseError (PFormula EqAtom)+parsePL str = parse propparser "" (dropWhile isSpace str)+parseLit :: Stream String Identity Char => String -> Either ParseError (LFormula EqAtom)+parseLit str = parse litparser "" (dropWhile isSpace str)+parseFOLTerm :: Stream String Identity Char => String -> Either ParseError FTerm+parseFOLTerm str = parse folsubterm "" (dropWhile isSpace str)++def :: forall s u m. Stream s m Char => GenLanguageDef s u m+def = emptyDef{ identStart = letter+              , identLetter = alphaNum <|> oneOf "'"+              , opStart = oneOf (nub (map head allOps))+              , opLetter = oneOf (nub (concat (map tail allOps)))+              , reservedOpNames = allOps+              , reservedNames = allIds+              }++m_parens :: forall t t1 t2. Stream t t2 Char => forall a. ParsecT t t1 t2 a -> ParsecT t t1 t2 a+m_angles :: forall t t1 t2. Stream t t2 Char => forall a. ParsecT t t1 t2 a -> ParsecT t t1 t2 a+m_symbol :: forall t t1 t2. Stream t t2 Char => String -> ParsecT t t1 t2 String+m_integer :: forall t t1 t2. Stream t t2 Char => ParsecT t t1 t2 Integer+m_identifier :: forall t t1 t2. Stream t t2 Char => ParsecT t t1 t2 String+m_reservedOp :: forall t t1 t2. Stream t t2 Char => String -> ParsecT t t1 t2 ()+m_reserved :: forall t t1 t2. Stream t t2 Char => String -> ParsecT t t1 t2 ()+m_whiteSpace :: forall t t1 t2. Stream t t2 Char => ParsecT t t1 t2 ()+TokenParser{ parens = m_parens+           , angles = m_angles+--           , brackets = m_brackets+           , symbol = m_symbol+           , integer = m_integer+           , identifier = m_identifier+           , reservedOp = m_reservedOp+           , reserved = m_reserved+--           , semiSep1 = m_semiSep1+           , whiteSpace = m_whiteSpace } = makeTokenParser def++#if 0+prologparser :: forall s u m. Stream s m Char => ParsecT s u m PrologRule+prologparser = try (do+   left <- folparser+   m_symbol ":-"+   right <- sepBy folparser (m_symbol ",")+   return (Prolog right left))+   <|> (do+   left <- folparser+   return (Prolog [] left))+   <?> "prolog expression"+#endif++litparser :: forall formula s u m. (JustLiteral formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula+litparser = litexprparser litterm+propparser :: forall formula s u m. (JustPropositional formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula+propparser = propexprparser propterm+folparser :: forall formula s u m. (IsQuantified formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula+folparser = propexprparser folterm++litexprparser :: forall formula s u m. (IsLiteral formula, Stream s m Char) => ParsecT s u m formula -> ParsecT s u m formula+litexprparser trm = buildExpressionParser table trm <?> "lit"+ where+  table = [ [Prefix (m_reservedOp "~" >> return (.~.))]+          ]++propexprparser :: forall formula s u m. (IsPropositional formula, Stream s m Char) => ParsecT s u m formula -> ParsecT s u m formula+propexprparser trm = buildExpressionParser table trm <?> "prop"+ where+  table = [ map (\op -> Prefix (m_reservedOp op >> return (.~.))) notOps+          , map (\op -> Infix (m_reservedOp op >> return (.&.)) AssocRight) andOps -- should these be assocLeft?+          , map (\op -> Infix (m_reservedOp op >> return (.|.)) AssocRight) orOps+          , map (\op -> Infix (m_reservedOp op >> return (.=>.)) AssocRight) impOps+          , map (\op -> Infix (m_reservedOp op >> return (.<=>.)) AssocRight) iffOps+          ]++litterm :: forall formula s u m. (JustLiteral formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula+litterm = try (m_parens litparser)+       <|> try folpredicate_infix+       <|> folpredicate+       <|> foldr1 (<|>) (map (\s -> m_reserved s >> return true) trueIds ++ map (\s -> m_reservedOp s >> return true) trueOps)+       <|> foldr1 (<|>) (map (\s -> m_reserved s >> return false) falseIds ++ map (\s -> m_reservedOp s >> return false) falseOps)++propterm :: forall formula s u m. (JustPropositional formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula+propterm = try (m_parens propparser)+       <|> try folpredicate_infix+       <|> folpredicate+       <|> foldr1 (<|>) (map (\s -> m_reserved s >> return true) trueIds ++ map (\s -> m_reservedOp s >> return true) trueOps)+       <|> foldr1 (<|>) (map (\s -> m_reserved s >> return false) falseIds ++ map (\s -> m_reservedOp s >> return false) falseOps)++folterm :: forall formula s u m. (IsQuantified formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula+folterm = try (m_parens folparser)+       <|> try folpredicate_infix+       <|> folpredicate+       <|> existentialQuantifier+       <|> forallQuantifier+       <|> foldr1 (<|>) (map (\s -> m_reserved s >> return true) trueIds ++ map (\s -> m_reservedOp s >> return true) trueOps)+       <|> foldr1 (<|>) (map (\s -> m_reserved s >> return false) falseIds ++ map (\s -> m_reservedOp s >> return false) falseOps)++existentialQuantifier :: forall formula s u m. (IsQuantified formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula+existentialQuantifier = foldr1 (<|>) (map (\ s -> quantifierId s (exists . fromString)) existsIds ++ map (\ s -> quantifierOp s (exists . fromString)) existsOps)+forallQuantifier :: forall formula s u m. (IsQuantified formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula+forallQuantifier = foldr1 (<|>) (map (\ s -> quantifierId s (for_all . fromString)) forallIds ++ map (\ s -> quantifierOp s (for_all . fromString)) forallOps)++quantifierId :: forall formula s u m. (IsQuantified formula, HasEquate (AtomOf formula), Stream s m Char) =>+              String -> (String -> formula -> formula) -> ParsecT s u m formula+quantifierId name op = do+   m_reserved name+   is <- many1 m_identifier+   _ <- m_symbol "."+   fm <- folparser+   return (foldr op fm is)++quantifierOp :: forall formula s u m. (IsQuantified formula, HasEquate (AtomOf formula), Stream s m Char) =>+              String -> (String -> formula -> formula) -> ParsecT s u m formula+quantifierOp name op = do+   m_reservedOp name+   is <- many1 m_identifier+   _ <- m_symbol "."+   fm <- folparser+   return (foldr op fm is)++folpredicate_infix :: forall formula s u m. (IsFormula formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula+folpredicate_infix = choice (map (try . app) predicate_infix_symbols)+ where+  app op = do+   x <- folsubterm+   m_reservedOp op+   y <- folsubterm+   return (if elem op equateOps then x .=. y else pApp (fromString op) [x, y])++folpredicate :: forall formula s u m. (IsFormula formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula+folpredicate = do+   p <- m_identifier <|> m_symbol "|--"+   xs <- option [] (m_parens (sepBy1 folsubterm (m_symbol ",")))+   return (pApp (fromString p) xs)++folfunction :: forall term s u m. (IsTerm term, Stream s m Char) => ParsecT s u m term+folfunction = do+   fname <- m_identifier+   xs <- m_parens (sepBy1 folsubterm (m_symbol ","))+   return (fApp (fromString fname) xs)++folconstant_numeric :: forall term t t1 t2. (IsTerm term, Stream t t2 Char) => ParsecT t t1 t2 term+folconstant_numeric = do+   i <- m_integer+   return (fApp (fromString . show $ i) [])++folconstant_reserved :: forall term t t1 t2. (IsTerm term, Stream t t2 Char) => String -> ParsecT t t1 t2 term+folconstant_reserved str = do+   m_reserved str+   return (fApp (fromString str) [])++folconstant :: forall term t t1 t2. (IsTerm term, Stream t t2 Char) => ParsecT t t1 t2 term+folconstant = do+   name <- m_angles m_identifier+   return (fApp (fromString name) [])++folsubterm :: forall term s u m. (IsTerm term, Stream s m Char) => ParsecT s u m term+folsubterm = folfunction_infix <|> folsubterm_prefix++folsubterm_prefix :: forall term s u m. (IsTerm term, Stream s m Char) => ParsecT s u m term+folsubterm_prefix =+   m_parens folfunction_infix+   <|> try folfunction+   <|> choice (map folconstant_reserved constants)+   <|> folconstant_numeric+   <|> folconstant+   <|> (fmap (vt . fromString) m_identifier)++folfunction_infix :: forall term s u m. (IsTerm term, Stream s m Char) => ParsecT s u m term+folfunction_infix = buildExpressionParser table folsubterm_prefix <?> "fof"+ where+  table = [ [Infix (m_reservedOp "::" >> return (\x y -> fApp (fromString "::") [x,y])) AssocRight]+          , [Infix (m_reservedOp "*" >> return (\x y -> fApp (fromString "*") [x,y])) AssocLeft, Infix (m_reservedOp "/" >> return (\x y -> fApp (fromString "/") [x,y])) AssocLeft]+          , [Infix (m_reservedOp "+" >> return (\x y -> fApp (fromString "+") [x,y])) AssocLeft, Infix (m_reservedOp "-" >> return (\x y -> fApp (fromString "-") [x,y])) AssocLeft]+          ]++allOps :: [String]+allOps = notOps ++ trueOps ++ falseOps ++ andOps ++ orOps ++ impOps ++ iffOps +++         forallOps ++ existsOps ++ equateOps ++ provesOps ++ entailsOps ++ predicate_infix_symbols++allIds :: [String]+allIds = trueIds ++ falseIds ++ existsIds ++ forallIds ++ constants++predicate_infix_symbols :: [String]+predicate_infix_symbols = equateOps ++ ["<",">","<=",">="]++constants :: [[Char]]+constants = ["nil"]++equateOps = ["=", ".=."]+provesOps = ["⊢", "|--"]+entailsOps = ["⊨", "|=="]++notOps :: [String]+notOps = ["¬", "~", ".~."]++trueOps, trueIds, falseOps, falseIds, provesOps, entailsOps, equateOps :: [String]+trueOps = ["⊤"]+trueIds = ["True", "true"]+falseOps = ["⊥"]+falseIds = ["False", "false"]++andOps, orOps, impOps, iffOps :: [String]+andOps = [".&.", "&", "∧", "⋀", "/\\", "·"]+orOps = ["|", "∨", "⋁", "+", ".|.", "\\/"]+impOps = ["==>", "⇒", "⟹", ".=>.", "→", "⊃"]+iffOps = ["<==>", "⇔", ".<=>.", "↔"]++forallIds, forallOps, existsIds, existsOps :: [String]+forallIds = ["forall", "for_all"]+forallOps= ["∀"]+existsIds = ["exists"]+existsOps = ["∃"]
+ src/Data/Logic/ATP/ParserTests.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes, RankNTypes, ScopedTypeVariables, TemplateHaskell #-}+module Data.Logic.ATP.ParserTests where++import Data.Logic.ATP.Equate ((.=.))+import Data.Logic.ATP.Pretty (assertEqual', Pretty(..), prettyShow, testEquals)+import Data.Logic.ATP.Prop ((.&.), (.=>.))+import Data.Logic.ATP.Parser (fof, parseFOL)+import Data.Logic.ATP.Skolem (Formula)+import Test.HUnit++t :: (Eq a, Pretty a) => String -> a -> a -> Test+t label expected actual = TestLabel label (TestCase (assertEqual' label expected actual))++parseFOL' :: String -> Either String Formula+parseFOL' = either (Left . show) Right . parseFOL++testParser :: Test+testParser =+    -- I would like these Lefts to work+    TestLabel "ParserTests"+      (TestList [ $(testEquals "precedence 1a") (Right [fof| (∃x. ⊤∧(∃y. ⊤)) |])+                       (parseFOL' " ∃x. (true & (∃y. true)) ")+                , $(testEquals "precedence 1b") (Right [fof| ∃x. (true & (∃y. true)) |])+                       (parseFOL " ∃x. (true & (∃y. true)) ")+                , $(testEquals "precedence 1c") (Right [fof|(∃x. ⊤∧(∃y. ⊤))|])+                       (parseFOL' " ∃x. true & ∃y. true ")+                , $(testEquals "precedence 2") [fof| (true & false) | true |]+                       [fof| true & false | true |]+                , $(testEquals "precedence 3") [fof| (true | false) <==> true |]+                       [fof| true | false <==> true |]+                , $(testEquals "precedence 4") [fof| true <==> (false ==> true) |]+                       [fof| true <==> false ==> true |]+                , $(testEquals "precedence 5") [fof| (~ true) & false |]+                       [fof| ~ true & false |]+                -- repeated prefix operator with same precedences fails:+                , $(testEquals "precedence 6") (Right [fof|(∃x y. (x=y))|])+                       (parseFOL' " ∃x. ∃y. x=y ")+                , $(testEquals "precedence 6b") [fof|(∃x. (∃y. (x=y)))|]+                       [fof| ∃x. (∃y. x=y) |]+                , $(testEquals "precedence 7") [fof| ∃x. (∃y. (x=y)) |]+                       [fof| ∃x y. x=y |]+                , $(testEquals "precedence 8") [fof| ∀x. (∃y. (x=y)) |]+                       [fof| ∀x. ∃y. x=y |]+                , $(testEquals "precedence 9") [fof| ∃y. (∀x. (x=y)) |]+                       [fof| ∃y. (∀x. x=y) |]+                , $(testEquals "precedence 10") [fof| (~P) & Q |]+                       [fof| ~P & Q |] -- ~ vs &+                -- repeated prefix operator with same precedences fails:+                , $(testEquals "precedence 10a") (Left "(line 1, column 3):\nunexpected '~'\nexpecting prop")+                       (parseFOL' " ~~P ")+                , $(testEquals "precedence 11") [fof| (P & Q) | R |]+                       [fof| P & Q | R |] -- & vs |+                , $(testEquals "precedence 12") [fof| (P | Q) ==> R |]+                       [fof| P | Q ==> R |] -- or vs imp+                , $(testEquals "precedence 13")  [fof| (P ==> Q) <==> R |]+                       [fof| P ==> Q <==> R |] -- imp vs iff+             -- , TestCase "precedence 14" [fof| ∃x. (∀y. x=y) |] [fof| ∃x.  ∀y. x=y |]+                , $(testEquals "precedence 14a") [fof| ((x = y) ∧ (x = z)) ⇒ (y = z) |]+                       ("x" .=. "y" .&. "x" .=. "z" .=>. "y" .=. "z")+                , $(testEquals "pretty 1") "∃x y. (∀z. (F(x,y)⇒F(y,z)∧F(z,z))∧(F(x,y)∧G(x,y)⇒G(x,z)∧G(z,z)))"+                       (prettyShow [fof| ∃ x y. (∀ z. ((F(x,y)⇒F(y,z)∧F(z,z))∧(F(x,y)∧G(x,y)⇒G(x,z)∧G(z,z)))) |])+                , $(testEquals "pretty 2") [fof| (∃x. (x=(f((g(x)))))∧(∀x'. x'=(f((g(x'))))⇒x=x'))⇔(∃y. y=(g((f(y))))∧(∀y'. y'=(g(f(y')))⇒y=y')) |]+                       [fof| (exists x. x = f(g(x)) /\ (forall x'. (x' = f(g(x'))) ==> (x = x'))) .<=>. (exists y. y = g(f(y)) /\ (forall y'. (y' = g(f(y'))) ==> (y = y'))) |]+                -- We could use haskell-src-meta to perform the third+                -- step of the round trip, roughly+                --+                --   1. formula string to parsed formula expression (Parser.parseExp)+                --   2. formula expression to parsed haskell-src-exts expression (show and th-lift?)+                --   3. haskell-src-exts to template-haskell expression (the toExp method of haskell-src-meta)+                --   4. template haskell back to haskell expression (template-haskell unquote)+{-+                , $(testEquals "read 1") (show (ParseOk (InfixApp (App+                                                                                                  (App (Var (UnQual (Ident "for_all"))) (Lit (String "x")))+                                                                                                  (Paren (Lit (String "x")))) (QVarOp (UnQual (Symbol ".=."))) (Paren (Lit (String "x"))))))+                       (show (parseExp (show [fof| ∀x. (x=x) |])))+                , $(testEquals "read 2") (show (ParseOk (InfixApp (App (App (App (App (Var (UnQual (Ident "for_all"))) (Lit (String "x")))+                                                                                                            (Var (UnQual (Ident "pApp"))))+                                                                                                       (Paren (App (Var (UnQual (Ident "fromString"))) (Lit (String "P")))))+                                                                                                  (List [Lit (String "x")]))+                                                                                        (QVarOp (UnQual (Symbol ".&.")))+                                                                                        (App (App (Var (UnQual (Ident "pApp")))+                                                                                              (Paren (App (Var (UnQual (Ident "fromString")))+                                                                                                      (Lit (String "Q")))))+                                                                                         (List [Lit (String "x")])))))+                       (show (parseExp (show [fof| ∀x. P(x) ∧ Q(x) |])))+-}+                , $(testEquals "parse 1") [fof| (forall x. i(x) * x = 1) ==> (forall x. i(x) * x = 1) |]+                       [fof| (forall x. i(x) * x = 1) ==> forall x. i(x) * x = 1 |]+                , $(testEquals "parse 2") "(*(i(x), x))=(1)" -- "i(x) * x = 1"+                       (prettyShow [fof| (i(x) * x = 1) |])+                , $(testEquals "parse 3") [fof| ⊤⇒(∀x. ⊤) |]+                       [fof| true ==> forall x. true |]+                , $(testEquals "parse 4") "⊤"+                       (prettyShow [fof| true |])+                , $(testEquals "parse 5") "⊥"+                       (prettyShow [fof| false |])+                ])
+ src/Data/Logic/ATP/Pretty.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -ddump-splices #-}++module Data.Logic.ATP.Pretty+    ( (<>)+    , Pretty(pPrint, pPrintPrec)+    , module Text.PrettyPrint.HughesPJClass+    , Associativity(InfixL, InfixR, InfixN, InfixA)+    , Precedence+    , HasFixity(precedence, associativity)+    , Side(Top, LHS, RHS, Unary)+    , testParen+    -- , parenthesize+    , assertEqual'+    , testEquals+    , leafPrec+    , boolPrec+    , notPrec+    , atomPrec+    , andPrec+    , orPrec+    , impPrec+    , iffPrec+    , quantPrec+    , eqPrec+    , pAppPrec+    ) where++import Control.Monad (unless)+import Data.Map.Strict as Map (Map, toList)+import Data.Monoid ((<>))+import Data.Set as Set (Set, toAscList)+import GHC.Stack+import Language.Haskell.TH (ExpQ, litE, stringL)+import Test.HUnit (Assertion, assertFailure, Test(TestLabel, TestCase))+import Text.PrettyPrint.HughesPJClass (brackets, comma, Doc, fsep, hcat, nest, Pretty(pPrint, pPrintPrec), prettyShow, punctuate, text)++-- | A class to extract the fixity of a formula so they can be+-- properly parenthesized.+--+-- 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@.  Hopefully, we can generate+-- formulas so that an associative operator with left associative+-- fixity direction appears as (a+b)+c rather than a+(b+c).+class HasFixity x where+    precedence :: x -> Precedence+    precedence _ = leafPrec+    associativity :: x -> Associativity+    associativity _ = InfixL++-- | Use the same precedence type as the pretty package+type Precedence = forall a. Num a => a++data Associativity+    = InfixL  -- Left-associative - a-b-c == (a-b)-c+    | InfixR  -- Right-associative - a=>b=>c == a=>(b=>c)+    | InfixN  -- Non-associative - a>b>c is an error+    | InfixA  -- Associative - a+b+c == (a+b)+c == a+(b+c), ~~a == ~(~a)+    deriving Show++-- | What side of the parent formula are we rendering?+data Side = Top | LHS | RHS | Unary deriving Show++-- | Decide whether to parenthesize based on which side of the parent binary+-- operator we are rendering, the parent operator's precedence, and the precedence+-- and associativity of the operator we are rendering.+-- testParen :: Side -> Precedence -> Precedence -> Associativity -> Bool+testParen :: (Eq a, Ord a, Num a) => Side -> a -> a -> Associativity -> Bool+testParen side parentPrec childPrec childAssoc =+    testPrecedence || (parentPrec == childPrec && testAssoc)+    -- parentPrec > childPrec || (parentPrec == childPrec && testAssoc)+    where+      testPrecedence =+          parentPrec > childPrec ||+          (parentPrec == orPrec && childPrec == andPrec) -- Special case - I can't keep these straight+      testAssoc = case (side, childAssoc) of+                    (LHS, InfixL) -> False+                    (RHS, InfixR) -> False+                    (_, InfixA) -> False+                    -- Tests from the previous version.+                    -- (RHS, InfixL) -> True+                    -- (LHS, InfixR) -> True+                    -- (Unary, _) -> braces pp -- not sure+                    -- (_, InfixN) -> error ("Nested non-associative operators: " ++ show pp)+                    _ -> True++instance Pretty a => Pretty (Set a) where+    pPrint = brackets . fsep . punctuate comma . map pPrint . Set.toAscList++instance (Pretty v, Pretty term) => Pretty (Map v term) where+    pPrint = pPrint . Map.toList++-- | Version of assertEqual that uses the pretty printer instead of show.+assertEqual' :: (?loc :: CallStack, Eq a, Pretty a) =>+                String -- ^ The message prefix+             -> a      -- ^ The expected value+             -> a      -- ^ The actual value+             -> Assertion+assertEqual' preface expected actual =+  unless (actual == expected) (assertFailure msg)+ where msg = (if null preface then "" else preface ++ "\n") +++             "expected: " ++ prettyShow expected ++ "\n but got: " ++ prettyShow actual++testEquals :: String -> ExpQ+testEquals label = [| \expected actual -> TestLabel $(litE (stringL label)) $ TestCase $ assertEqual' $(litE (stringL label)) expected actual|]++leafPrec :: Num a => a+leafPrec = 9++atomPrec :: Num a => a+atomPrec = 7+notPrec :: Num a => a+notPrec = 6+andPrec :: Num a => a+andPrec = 5+orPrec :: Num a => a+orPrec = 4+impPrec :: Num a => a+impPrec = 3+iffPrec :: Num a => a+iffPrec = 2+boolPrec :: Num a => a+boolPrec = leafPrec+quantPrec :: Num a => a+quantPrec = 1+eqPrec :: Num a => a+eqPrec = 6+pAppPrec :: Num a => a+pAppPrec = 9
+ src/Data/Logic/ATP/Prolog.hs view
@@ -0,0 +1,206 @@+-- | Backchaining procedure for Horn clauses, and toy Prolog implementation.++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}++module Data.Logic.ATP.Prolog where++import Data.List as List (map)+import Data.Logic.ATP.Apply (HasApply(TermOf))+import Data.Logic.ATP.FOL (var, lsubst)+import Data.Logic.ATP.Formulas (IsFormula(AtomOf))+-- import Data.Logic.ATP.Lib (deepen)+import Data.Logic.ATP.Lit (IsLiteral, JustLiteral)+import Data.Logic.ATP.Term (IsTerm(TVarOf), vt)+import Data.Map.Strict as Map+import Data.Set as Set+import Data.String (fromString)+import Test.HUnit++data PrologRule lit = Prolog (Set lit) lit deriving (Eq, Ord)++-- -------------------------------------------------------------------------+-- Rename a rule.+-- -------------------------------------------------------------------------++renamerule :: forall lit atom term v.+              (IsLiteral lit, JustLiteral lit, Ord lit, HasApply atom, IsTerm term,+               atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+              Int -> PrologRule lit -> (PrologRule lit, Int)+renamerule k (Prolog asm c) =+    (Prolog (Set.map inst asm) (inst c), k + Set.size fvs)+    where+      fvs = Set.fold (Set.union . var) (Set.empty :: Set v) (Set.insert c asm)+      vvs = Map.fromList (List.map (\(v, i) -> (v, vt (fromString ("_" ++ show i)))) (zip (Set.toList fvs) [k..]))+      inst = lsubst vvs++{-++(* ------------------------------------------------------------------------- *)+(* Basic prover for Horn clauses based on backchaining with unification.     *)+(* ------------------------------------------------------------------------- *)++let rec backchain rules n k env goals =+  match goals with+    [] -> env+  | g::gs ->+     if n = 0 then failwith "Too deep" else+     tryfind (fun rule ->+        let (a,c),k' = renamerule k rule in+        backchain rules (n - 1) k' (unify_literals env (c,g)) (a @ gs))+     rules;;++let hornify cls =+  let pos,neg = partition positive cls in+  if length pos > 1 then failwith "non-Horn clause"+  else (map negate neg,if pos = [] then False else hd pos);;++let hornprove fm =+  let rules = map hornify (simpcnf(skolemize(Not(generalize fm)))) in+  deepen (fun n -> backchain rules n 0 undefined [False],n) 0;;++(* ------------------------------------------------------------------------- *)+(* A Horn example.                                                           *)+(* ------------------------------------------------------------------------- *)++START_INTERACTIVE;;+let p32 = hornprove+ <<(forall x. P(x) /\ (G(x) \/ H(x)) ==> Q(x)) /\+   (forall x. Q(x) /\ H(x) ==> J(x)) /\+   (forall x. R(x) ==> H(x))+   ==> (forall x. P(x) /\ R(x) ==> J(x))>>;;++(* ------------------------------------------------------------------------- *)+(* A non-Horn example.                                                       *)+(* ------------------------------------------------------------------------- *)++(****************++hornprove <<(p \/ q) /\ (~p \/ q) /\ (p \/ ~q) ==> ~(~q \/ ~q)>>;;++**********)+END_INTERACTIVE;;++(* ------------------------------------------------------------------------- *)+(* Parsing rules in a Prolog-like syntax.                                    *)+(* ------------------------------------------------------------------------- *)++let parserule s =+  let c,rest =+    parse_formula (parse_infix_atom,parse_atom) [] (lex(explode s)) in+  let asm,rest1 =+    if rest <> [] & hd rest = ":-"+    then parse_list ","+          (parse_formula (parse_infix_atom,parse_atom) []) (tl rest)+    else [],rest in+  if rest1 = [] then (asm,c) else failwith "Extra material after rule";;++(* ------------------------------------------------------------------------- *)+(* Prolog interpreter: just use depth-first search not iterative deepening.  *)+(* ------------------------------------------------------------------------- *)++let simpleprolog rules gl =+  backchain (map parserule rules) (-1) 0 undefined [parse gl];;++(* ------------------------------------------------------------------------- *)+(* Ordering example.                                                         *)+(* ------------------------------------------------------------------------- *)++START_INTERACTIVE;;+let lerules = ["0 <= X"; "S(X) <= S(Y) :- X <= Y"];;++simpleprolog lerules "S(S(0)) <= S(S(S(0)))";;++(*** simpleprolog lerules "S(S(0)) <= S(0)";;+ ***)++let env = simpleprolog lerules "S(S(0)) <= X";;+apply env "X";;+END_INTERACTIVE;;++(* ------------------------------------------------------------------------- *)+(* With instantiation collection to produce a more readable result.          *)+(* ------------------------------------------------------------------------- *)++let prolog rules gl =+  let i = solve(simpleprolog rules gl) in+  mapfilter (fun x -> Atom(R("=",[Var x; apply i x]))) (fv(parse gl));;++(* ------------------------------------------------------------------------- *)+(* Example again.                                                            *)+(* ------------------------------------------------------------------------- *)++START_INTERACTIVE;;+prolog lerules "S(S(0)) <= X";;++(* ------------------------------------------------------------------------- *)+(* Append example, showing symmetry between inputs and outputs.              *)+(* ------------------------------------------------------------------------- *)++let appendrules =+  ["append(nil,L,L)"; "append(H::T,L,H::A) :- append(T,L,A)"];;++prolog appendrules "append(1::2::nil,3::4::nil,Z)";;++prolog appendrules "append(1::2::nil,Y,1::2::3::4::nil)";;++prolog appendrules "append(X,3::4::nil,1::2::3::4::nil)";;++prolog appendrules "append(X,Y,1::2::3::4::nil)";;++(* ------------------------------------------------------------------------- *)+(* However this way round doesn't work.                                      *)+(* ------------------------------------------------------------------------- *)++(***+ *** prolog appendrules "append(X,3::4::nil,X)";;+ ***)++(* ------------------------------------------------------------------------- *)+(* A sorting example (from Lloyd's "Foundations of Logic Programming").      *)+(* ------------------------------------------------------------------------- *)++let sortrules =+ ["sort(X,Y) :- perm(X,Y),sorted(Y)";+  "sorted(nil)";+  "sorted(X::nil)";+  "sorted(X::Y::Z) :- X <= Y, sorted(Y::Z)";+  "perm(nil,nil)";+  "perm(X::Y,U::V) :- delete(U,X::Y,Z), perm(Z,V)";+  "delete(X,X::Y,Y)";+  "delete(X,Y::Z,Y::W) :- delete(X,Z,W)";+  "0 <= X";+  "S(X) <= S(Y) :- X <= Y"];;++prolog sortrules+  "sort(S(S(S(S(0))))::S(0)::0::S(S(0))::S(0)::nil,X)";;++(* ------------------------------------------------------------------------- *)+(* Yet with a simple swap of the first two predicates...                     *)+(* ------------------------------------------------------------------------- *)++let badrules =+ ["sort(X,Y) :- sorted(Y), perm(X,Y)";+  "sorted(nil)";+  "sorted(X::nil)";+  "sorted(X::Y::Z) :- X <= Y, sorted(Y::Z)";+  "perm(nil,nil)";+  "perm(X::Y,U::V) :- delete(U,X::Y,Z), perm(Z,V)";+  "delete(X,X::Y,Y)";+  "delete(X,Y::Z,Y::W) :- delete(X,Z,W)";+  "0 <= X";+  "S(X) <= S(Y) :- X <= Y"];;++(*** This no longer works++prolog badrules+  "sort(S(S(S(S(0))))::S(0)::0::S(S(0))::S(0)::nil,X)";;++ ***)+END_INTERACTIVE;;+-}++testProlog :: Test+testProlog = TestLabel "Prolog" (TestList [])
+ src/Data/Logic/ATP/Prop.hs view
@@ -0,0 +1,1115 @@+-- | Basic stuff for propositional logic: datatype, parsing and+-- printing.  'IsPropositional' is a subclass of 'IsLiteral' of+-- formula types that support binary combinations.++{-# OPTIONS_GHC -Wall #-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Logic.ATP.Prop+    ( -- * binary operations+      BinOp(..), binop+    -- * Propositional formulas+    , IsPropositional((.|.), (.&.), (.<=>.), (.=>.), foldPropositional', foldCombination)+    , (⇒), (==>), (⊃), (→)+    , (⇔), (<=>), (↔), (<==>)+    , (∧), (·)+    , (∨)+    , foldPropositional+    , zipPropositional+    , convertPropositional+    , convertToPropositional+    , precedencePropositional+    , associativityPropositional+    , prettyPropositional+    , showPropositional+    , onatomsPropositional+    , overatomsPropositional+    -- * Restricted propositional formula class+    , JustPropositional+    -- * Interpretation of formulas.+    , eval+    , atoms+    -- * Truth Tables+    , TruthTable(TruthTable)+    , onallvaluations+    , truthTable+    -- * Tautologies and related concepts+    , tautology+    , unsatisfiable+    , satisfiable+    -- * Substitution+    , psubst+    -- * Dualization+    , dual+    -- * Simplification+    , psimplify+    , psimplify1+    -- * Normal forms+    , nnf+    , nenf+    , list_conj+    , list_disj+    , mk_lits+    , allsatvaluations+    , dnfSet+    , purednf+    , simpdnf+    , rawdnf+    , dnf+    , purecnf+    , simpcnf+    , cnf'+    , cnf_+    , trivial+    -- * Instance+    , Prop(P, pname)+    , PFormula(F, T, Atom, Not, And, Or, Imp, Iff)+    -- * Tests+    , testProp+    ) where++import Data.Foldable as Foldable (null)+import Data.Function (on)+import Data.Data (Data)+import Data.List as List (groupBy, intercalate, map, sortBy)+import Data.Logic.ATP.Formulas (atom_union, fromBool, IsAtom,+                                IsFormula(AtomOf, asBool, true, false, atomic, overatoms, onatoms), prettyBool)+import Data.Logic.ATP.Lib ((|=>), distrib, fpf, setAny)+import Data.Logic.ATP.Lit ((.~.), (¬), convertLiteral, convertToLiteral, IsLiteral(foldLiteral', naiveNegate, foldNegation),+                           JustLiteral, LFormula, negate, positive, )+import Data.Logic.ATP.Pretty (Associativity(InfixN, InfixR, InfixA), Doc, HasFixity(precedence, associativity),+                              Precedence, Pretty(pPrint, pPrintPrec), prettyShow, Side(Top, LHS, RHS, Unary), testParen, text,+                              notPrec, andPrec, orPrec, impPrec, iffPrec, leafPrec, boolPrec)+import Data.Map.Strict as Map (Map)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Set as Set (empty, filter, fromList, intersection, isProperSubsetOf, map,+                        minView, partition, Set, singleton, toAscList, union)+import Data.String (IsString(fromString))+import Data.Typeable (Typeable)+import Prelude hiding (negate, null)+import Text.PrettyPrint.HughesPJClass (maybeParens, PrettyLevel, vcat)+import Test.HUnit++-- | Implication synonyms.  Note that if the -XUnicodeSyntax option is+-- turned on the operator ⇒ can not be declared/used as a function -+-- it becomes a reserved special character used in type signatures.+(⇒), (⊃), (==>), (→) :: IsPropositional formula => formula -> formula -> formula+(⇒) = (.=>.)+(⊃) = (.=>.)+(==>) = (.=>.)+(→) = (.=>.)+infixr 3 .=>., ⇒, ⊃, ==>, →++-- | If-and-only-if synonyms+(<=>), (<==>), (⇔), (↔) :: IsPropositional formula => formula -> formula -> formula+(<=>) = (.<=>.)+(<==>) = (.<=>.)+(⇔) = (.<=>.)+(↔) = (.<=>.)+infixl 2 .<=>., <=>, <==>, ⇔, ↔++-- | And/conjunction synonyms+(∧), (·) :: IsPropositional formula => formula -> formula -> formula+(∧) = (.&.)+(·) = (.&.)+infixl 5 .&., ∧, ·++-- | Or/disjunction synonyms+(∨) :: IsPropositional formula => formula -> formula -> formula+(∨) = (.|.)+infixl 4 .|., ∨++data BinOp+    = (:<=>:)+    | (:=>:)+    | (:&:)+    | (:|:)+    deriving (Eq, Ord, Data, Typeable, Show, Enum, Bounded)++-- | Combine formulas with a 'BinOp'.+binop :: IsPropositional formula => formula -> BinOp -> formula -> formula+binop f1 (:<=>:) f2 = f1 .<=>. f2+binop f1 (:=>:) f2 = f1 .=>. f2+binop f1 (:&:) f2 = f1 .&. f2+binop f1 (:|:) f2 = f1 .|. f2++-- |A type class for propositional logic.  If the type we are writing+-- an instance for is a zero-order (aka propositional) logic type+-- there will generally by a type or a type parameter corresponding to+-- atom.  For first order or predicate logic types, it is generally+-- easiest to just use the formula type itself as the atom type, and+-- raise errors in the implementation if a non-atomic formula somehow+-- appears where an atomic formula is expected (i.e. as an argument to+-- atomic or to the third argument of foldPropositional.)+class IsLiteral formula => IsPropositional formula where+    -- | Disjunction/OR+    (.|.) :: formula -> formula -> formula+    -- | Conjunction/AND.  @x .&. y = (.~.) ((.~.) x .|. (.~.) y)@+    (.&.) :: formula -> formula -> formula+    -- | Equivalence.  @x .<=>. y = (x .=>. y) .&. (y .=>. x)@+    (.<=>.) :: formula -> formula -> formula+    -- | Implication.  @x .=>. y = ((.~.) x .|. y)@+    (.=>.) :: formula -> formula -> formula++    -- | A fold function that distributes different sorts of formula+    -- to its parameter functions, one to handle binary operators, one+    -- for negations, and one for atomic formulas.  See examples of its+    -- use to implement the polymorphic functions below.+    foldPropositional' :: (formula -> r)                     -- ^ fold on some higher order formula+                       -> (formula -> BinOp -> formula -> r) -- ^ fold on a binary operation formula.  Functions+                                                             -- of this type can be constructed using 'binop'.+                       -> (formula -> r)                     -- ^ fold on a negated formula+                       -> (Bool -> r)                        -- ^ fold on a boolean formula+                       -> (AtomOf formula -> r)              -- ^ fold on an atomic formula+                       -> formula -> r+    -- | An alternative fold function for binary combinations of formulas+    foldCombination :: (formula -> r) -- other+                    -> (formula -> formula -> r) -- disjunction+                    -> (formula -> formula -> r) -- conjunction+                    -> (formula -> formula -> r) -- implication+                    -> (formula -> formula -> r) -- equivalence+                    -> formula -> r++-- | Deconstruct a 'JustPropositional' formula.+foldPropositional :: JustPropositional pf =>+                     (pf -> BinOp -> pf -> r) -- ^ fold on a binary operation formula+                  -> (pf -> r)                -- ^ fold on a negated formula+                  -> (Bool -> r)              -- ^ fold on a boolean formula+                  -> (AtomOf pf -> r)         -- ^ fold on an atomic formula+                  -> pf -> r+foldPropositional = foldPropositional' (error "JustPropositional failure")++-- | Combine two 'JustPropositional' formulas if they are similar.+zipPropositional :: (JustPropositional pf1, JustPropositional pf2) =>+                    (pf1 -> BinOp -> pf1 -> pf2 -> BinOp -> pf2 -> Maybe r) -- ^ Combine two binary operation formulas+                 -> (pf1 -> pf2 -> Maybe r)                                 -- ^ Combine two negated formulas+                 -> (Bool -> Bool -> Maybe r)                               -- ^ Combine two boolean formulas+                 -> (AtomOf pf1 -> AtomOf pf2 -> Maybe r)                   -- ^ Combine two atomic formulas+                 -> pf1 -> pf2 -> Maybe r                                   -- ^ Result is Nothing if the formulas don't unify+zipPropositional co ne tf at fm1 fm2 =+    foldPropositional co' ne' tf' at' fm1+    where+      co' l1 op1 r1 = foldPropositional (co l1 op1 r1) (\_ -> Nothing) (\_ -> Nothing) (\_ -> Nothing) fm2+      ne' x1 = foldPropositional (\_ _ _ -> Nothing)     (ne x1)     (\_ -> Nothing) (\_ -> Nothing) fm2+      tf' x1 = foldPropositional (\_ _ _ -> Nothing) (\_ -> Nothing)     (tf x1)     (\_ -> Nothing) fm2+      at' a1 = foldPropositional (\_ _ _ -> Nothing) (\_ -> Nothing) (\_ -> Nothing)     (at a1)     fm2++-- | Convert any instance of 'JustPropositional' to any 'IsPropositional' formula.+convertPropositional :: (JustPropositional pf1, IsPropositional pf2) =>+                        (AtomOf pf1 -> AtomOf pf2) -- ^ Convert an atomic formula+                     -> pf1 -> pf2+convertPropositional ca pf =+    foldPropositional co ne tf (atomic . ca) pf+    where+      co p (:&:) q = (convertPropositional ca p) .&. (convertPropositional ca q)+      co p (:|:) q = (convertPropositional ca p) .|. (convertPropositional ca q)+      co p (:=>:) q = (convertPropositional ca p) .=>. (convertPropositional ca q)+      co p (:<=>:) q = (convertPropositional ca p) .<=>. (convertPropositional ca q)+      ne p = (.~.) (convertPropositional ca p)+      tf = fromBool++-- | Convert any instance of 'IsPropositional' to a 'JustPropositional' formula.  Typically the+-- ho (higher order) argument calls error if it encounters something it can't handle.+convertToPropositional :: (IsPropositional formula, JustPropositional pf) =>+                          (formula -> pf)               -- ^ Convert a higher order formula+                       -> (AtomOf formula -> AtomOf pf) -- ^ Convert an atomic formula+                       -> formula -> pf+convertToPropositional ho ca fm =+    foldPropositional' ho co ne tf (atomic . ca) fm+    where+      co p (:&:) q = (convertToPropositional ho ca p) .&. (convertToPropositional ho ca q)+      co p (:|:) q = (convertToPropositional ho ca p) .|. (convertToPropositional ho ca q)+      co p (:=>:) q = (convertToPropositional ho ca p) .=>. (convertToPropositional ho ca q)+      co p (:<=>:) q = (convertToPropositional ho ca p) .<=>. (convertToPropositional ho ca q)+      ne p = (.~.) (convertToPropositional ho ca p)+      tf = fromBool++-- | Implementation of 'precedence' for any 'JustPropostional' type.+precedencePropositional ::JustPropositional pf => pf -> Precedence+precedencePropositional = foldPropositional co (\_ -> notPrec) (\_ -> boolPrec) precedence+    where+      co _ (:&:) _ = andPrec+      co _ (:|:) _ = orPrec+      co _ (:=>:) _ = impPrec+      co _ (:<=>:) _ = iffPrec++associativityPropositional :: JustPropositional pf => pf -> Associativity+associativityPropositional = foldPropositional co (const InfixA) (const InfixN) associativity+    where+      co _ (:&:) _ = InfixA+      co _ (:|:) _ = InfixA+      co _ (:=>:) _ = InfixR+      co _ (:<=>:) _ = InfixA -- yes, InfixA: (a<->b)<->c == a<->(b<->c)++-- | Implementation of 'pPrint' for any 'JustPropostional' type.+prettyPropositional :: forall pf. JustPropositional pf =>+                       Side -> PrettyLevel -> Rational -> pf -> Doc+prettyPropositional side l r fm =+    maybeParens (testParen side r (precedence fm) (associativity fm)) $ foldPropositional co ne tf at fm+    where+      co :: pf -> BinOp -> pf -> Doc+      co p (:&:) q = prettyPropositional LHS l (precedence fm) p <> text "∧" <>  prettyPropositional RHS l (precedence fm) q+      co p (:|:) q = prettyPropositional LHS l (precedence fm) p <> text "∨" <> prettyPropositional RHS l (precedence fm) q+      co p (:=>:) q = prettyPropositional LHS l (precedence fm) p <> text "⇒" <> prettyPropositional RHS l (precedence fm) q+      co p (:<=>:) q = prettyPropositional LHS l (precedence fm) p <> text "⇔" <> prettyPropositional RHS l (precedence fm) q+      ne p = text "¬" <> prettyPropositional Unary l (precedence fm) p+      tf x = prettyBool x+      at x = pPrintPrec l r x++-- | Implementation of 'show' for any 'JustPropositional' type.  For clarity, show methods fully parenthesize+showPropositional :: JustPropositional pf => Side -> Int -> pf -> ShowS+showPropositional side parentPrec fm =+    showParen (testParen side parentPrec (precedence fm) (associativity fm)) $ foldPropositional co ne tf at fm+    where+      co p (:&:) q = showPropositional LHS (precedence fm) p . showString " .&. " . showPropositional RHS (precedence fm) q+      co p (:|:) q = showPropositional LHS (precedence fm) p . showString " .|. " . showPropositional RHS (precedence fm) q+      co p (:=>:) q = showPropositional LHS (precedence fm) p . showString " .=>. " . showPropositional RHS (precedence fm) q+      co p (:<=>:) q = showPropositional LHS (precedence fm) p . showString " .<=>. " . showPropositional RHS (precedence fm) q+      ne p = showString "(.~.) " . showPropositional Unary (succ (precedence fm)) p+      tf x = showsPrec (precedence fm) x+      at x = showString "atomic " . showsPrec (precedence fm) x++-- | Implementation of 'onatoms' for any 'JustPropositional' type.+onatomsPropositional :: JustPropositional pf => (AtomOf pf -> AtomOf pf) -> pf -> pf+onatomsPropositional f fm =+    foldPropositional co ne tf at fm+    where+      co p op q = binop (onatomsPropositional f p) op (onatomsPropositional f q)+      ne p = (.~.) (onatomsPropositional f p)+      tf flag = fromBool flag+      at x = atomic (f x)++-- | Implementation of 'overatoms' for any 'JustPropositional' type.+overatomsPropositional :: JustPropositional pf => (AtomOf pf -> r -> r) -> pf -> r -> r+overatomsPropositional f fof r0 =+    foldPropositional co ne (const r0) (flip f r0) fof+    where+      co p _ q = overatomsPropositional f p (overatomsPropositional f q r0)+      ne fof' = overatomsPropositional f fof' r0++-- | An instance of IsPredicate.+data Prop = P {pname :: String} deriving (Eq, Ord)++-- Because of the IsString instance, the Show instance can just be a String.+instance Show Prop where+    show (P {pname = s}) = show s++instance IsAtom Prop++-- Allows us to say "q" instead of P "q" or P {pname = "q"}+instance IsString Prop where+    fromString = P++instance Pretty Prop where+    pPrint = text . pname++instance HasFixity Prop where+    precedence (P _) = leafPrec++-- | An instance of IsPropositional.+data PFormula atom+    = F+    | T+    | Atom atom+    | Not (PFormula atom)+    | And (PFormula atom) (PFormula atom)+    | Or (PFormula atom) (PFormula atom)+    | Imp (PFormula atom) (PFormula atom)+    | Iff (PFormula atom) (PFormula atom)+    deriving (Eq, Ord, Read, Data, Typeable)++-- Build a Haskell expression for this formula+instance (IsPropositional (PFormula atom), Show atom) => Show (PFormula atom) where+    showsPrec p x = showPropositional Top p x -- . showString " :: PFormula Prop"++instance IsAtom atom => HasFixity (PFormula atom) where+    precedence = precedencePropositional+    associativity = associativityPropositional++instance IsAtom atom => IsFormula (PFormula atom) where+    type AtomOf (PFormula atom) = atom+    asBool T = Just True+    asBool F = Just False+    asBool _ = Nothing+    true = T+    false = F+    atomic = Atom+    overatoms = overatomsPropositional+    onatoms = onatomsPropositional++instance IsAtom atom => IsPropositional (PFormula atom) where+    (.|.) = Or+    (.&.) = And+    (.=>.) = Imp+    (.<=>.) = Iff+    foldPropositional' _ co ne tf at fm =+        case fm of+          Imp p q -> co p (:=>:) q+          Iff p q -> co p (:<=>:) q+          And p q -> co p (:&:) q+          Or p q -> co p (:|:) q+          _ -> foldLiteral' (error "IsPropositional PFormula") ne tf at fm+    foldCombination other dj cj imp iff fm =+        case fm of+          Or a b -> a `dj` b+          And a b -> a `cj` b+          Imp a b -> a `imp` b+          Iff a b -> a `iff` b+          _ -> other fm++instance IsAtom atom => IsLiteral (PFormula atom) where+    naiveNegate = Not+    foldNegation normal inverted (Not x) = foldNegation inverted normal x+    foldNegation normal _ x = normal x+    foldLiteral' ho ne tf at fm =+        case fm of+          T -> tf True+          F -> tf False+          Atom a -> at a+          Not l -> ne l+          _ -> ho fm++instance IsAtom atom => Pretty (PFormula atom) where+    pPrintPrec = prettyPropositional Top++-- | Class that indicates a formula type *only* supports Propositional+-- features - it has no way to represent quantifiers.+class IsPropositional formula => JustPropositional formula++instance IsAtom atom => JustPropositional (PFormula atom)++-- | Interpretation of formulas.+eval :: JustPropositional pf => pf -> (AtomOf pf -> Bool) -> Bool+eval fm v =+    foldPropositional co ne tf at fm+    where+      co p (:&:) q = (eval p v) && (eval q v)+      co p (:|:) q = (eval p v) || (eval q v)+      co p (:=>:) q = not (eval p v) || (eval q v)+      co p (:<=>:) q = (eval p v) == (eval q v)+      ne p = not (eval p v)+      tf = id+      at = v++-- | Recognizing tautologies.+tautology :: JustPropositional pf => pf -> Bool+tautology fm = onallvaluations (&&) (eval fm) (\_s -> False) (atoms fm)++-- | Related concepts.+unsatisfiable :: JustPropositional pf => pf -> Bool+unsatisfiable = tautology . (.~.)+satisfiable :: JustPropositional pf  => pf -> Bool+satisfiable = not . unsatisfiable++onallvaluations :: Ord atom => (r -> r -> r) -> ((atom -> Bool) -> r) -> (atom -> Bool) -> Set atom -> r+onallvaluations cmb subfn v ats =+    case minView ats of+      Nothing -> subfn v+      Just (p, ps) ->+          let v' t q = (if q == p then t else v q) in+          cmb (onallvaluations cmb subfn (v' False) ps) (onallvaluations cmb subfn (v' True) ps)++-- | Return the set of propositional variables in a formula.+atoms :: IsFormula formula => formula -> Set (AtomOf formula)+atoms fm = atom_union singleton fm++data TruthTable a = TruthTable [a] [TruthTableRow] deriving (Eq, Show)+type TruthTableRow = ([Bool], Bool)++-- | Code to print out truth tables.+truthTable :: JustPropositional pf => pf -> TruthTable (AtomOf pf)+truthTable fm =+    TruthTable atl (onallvaluations (<>) mkRow (const False) ats)+    where+      ats = atoms fm+      mkRow v = [(List.map v atl, eval fm v)]+      atl = Set.toAscList ats++instance Pretty atom => Pretty (TruthTable atom) where+    pPrint (TruthTable ats rows) = vcat (List.map (text . intercalate "|" . center) rows'')+        where+          center :: [String] -> [String]+          center cols = Prelude.map (uncurry center') (zip colWidths cols)+          center' :: Int -> String -> String+          center' width s = let (q, r) = divMod (width - length s) 2 in replicate q ' ' ++ s ++ replicate (q + r) ' '+          hdrs = List.map prettyShow ats ++ ["result"]+          rows'' = hdrs : List.map (uncurry replicate) (zip colWidths (repeat '-')) : rows'+          rows' :: [[String]]+          rows' = List.map (\(cols, result) -> List.map prettyShow (cols ++ [result])) rows+          cellWidths :: [[Int]]+          cellWidths = List.map (List.map length) (hdrs : rows')+          colWidths :: [Int]+          colWidths = List.map (foldl1 max) (transpose cellWidths)++transpose               :: [[a]] -> [[a]]+transpose []             = []+transpose ([]   : xss)   = transpose xss+transpose ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (xs : [ t | (_:t) <- xss])++-- | Make sure the precedence and associativity implied by the Haskell+-- infix/infixl/infixr declarations matches the precedence and+-- associativity implied by the HasFixity instances.  It would be nice+-- to define one in terms of the other, but I don't know how to query+-- the precedence and associativity of an operator, and I don't know+-- how to (successfully) generate an infix/infixl/infixr declaration+-- using template haskell (the obvious thing didn't work:+--+--    $(pure [InfixD (Fixity quantPrec TH.InfixR) '(∀)])++-- | Tests precedence handling in pretty+-- printer.  1. Need to test: associativity of like operators+-- 2. precedence of every pair of adjacent operators 3. Stuff about+-- infix operators+test00 :: Test+test00 =+{-+    TestList [testPrecedence, testAssociativity]+    where+      testPrecedence :: Test+      testPrecedence =+          TestList (+-}+    TestList (List.map (\(input, expected) -> TestCase $ assertEqual "precedence" (text expected) (pPrint input))+                      [( p .&. (q .|. r)   , "p∧(q∨r)" ),+                       ( (p .&. q) .|. r   , "(p∧q)∨r" ),+                       ( p .&. q .|. r     , "(p∧q)∨r" ),+                       ( p .|. q .&. r     , "p∨(q∧r)" ),+                       ( p .&. q .&. r     , "p∧q∧r"   ),+                       ( p .|. q .|. r     , "p∨q∨r"   ),+                       ( (p .=>. q) .=>. r , "(p⇒q)⇒r" ),+                       ( p .=>. (q .=>. r) , "p⇒q⇒r"   ),+                       ( p .=>. q .=>. r   , "p⇒q⇒r"   )])+    where+      byPrec :: IsPropositional formula => [[(Rational, formula -> formula -> formula)]]+      byPrec = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ binops+      -- All the operators we will test, with the 'Precedence' value+      -- we assigned.  we need to make sure the 'Precedence' value+      -- matches the values in the infix/infixl/infixr declarations.+      binops :: IsPropositional formula => [(Rational, formula -> formula -> formula)]+      binops = ands ++ ors ++ imps ++ iffs+          where+            ands :: IsPropositional formula => [(Rational, formula -> formula -> formula)]+            ands = List.map (andPrec,) [(.&.), (∧), (·)]+            ors :: IsPropositional formula => [(Rational, formula -> formula -> formula)]+            ors = List.map (orPrec,) [(.|.), (∨)]+            imps :: IsPropositional formula => [(Rational, formula -> formula -> formula)]+            imps = List.map (impPrec,) [(.=>.), (⇒), (==>), (→), (⊃)]+            iffs :: IsPropositional formula => [(Rational, formula -> formula -> formula)]+            iffs = List.map (iffPrec,) [(.<=>.), (<=>), (⇔), (↔)]+      preops :: IsPropositional formula => [(Rational, formula -> formula)]+      preops = nots+          where+            nots :: IsPropositional formula => [(Rational, formula -> formula)]+            nots = List.map (notPrec,) [(.~.), (¬)]+      (p, q, r) = (Atom (P "p"), Atom (P "q"), Atom (P "r"))+      -- What about these?+      -- (∴)+++{-+test00 = TestCase $ assertEqual "parenthesization" expected (List.map prettyShow input)+          (input, expected) = unzip [( p .&. (q .|. r)   , "p∧(q∨r)" ),+                                     ( (p .&. q) .|. r   , "(p∧q)∨r" ),+                                     ( p .&. q .|. r     , "(p∧q)∨r" ),+                                     ( p .|. q .&. r     , "p∨(q∧r)" ),+                                     ( p .&. q .&. r     , "p∧q∧r"   ),+                                     ( (p .=>. q) .=>. r , "(p⇒q)⇒r" ),+                                     ( p .=>. (q .=>. r) , "p⇒q⇒r"   ),+                                     ( p .=>. q .=>. r   , "p⇒q⇒r"   )]+-}++test01 :: Test+test01 =+    let fm = atomic "p" .=>. atomic "q" .<=>. (atomic "r" .&. atomic "s") .|. (atomic "t" .<=>. ((.~.) ((.~.) (atomic "u"))) .&. atomic "v") :: PFormula Prop+        input = (prettyShow fm, show fm)+        expected = (-- Pretty printed+                    "p⇒q⇔(r∧s)∨(t⇔u∧v)",+                    -- Haskell expression+                    "atomic \"p\" .=>. atomic \"q\" .<=>. (atomic \"r\" .&. atomic \"s\") .|. (atomic \"t\" .<=>. atomic \"u\" .&. atomic \"v\")"+                    ) in+    TestCase $ assertEqual "Build Formula 1" expected input++test02 :: Test+test02 = TestCase $ assertEqual "Build Formula 2" expected input+    where input = (Atom "fm" .&. Atom "fm") :: PFormula Prop+          expected = (And (Atom "fm") (Atom "fm"))++test03 :: Test+test03 = TestCase $ assertEqual "Build Formula 3"+                                (Atom "fm" .|. Atom "fm" .&. Atom "fm" :: PFormula Prop)+                                (Or (Atom "fm") (And (Atom "fm") (Atom "fm")))++-- Example of use.++test04 :: Test+test04 = TestCase $ assertEqual "fixity tests" expected input+    where (input, expected) = unzip (List.map (\ (fm, flag) -> (eval fm v0, flag)) pairs)+          v0 x = error $ "v0: " ++ show x+          pairs :: [(PFormula Prop, Bool)]+          pairs =+              [ ( true .&. false .=>. false .&. true,  True)+              , ( true .&. true  .=>. true  .&. false, False)+              , (   false ∧  true  ∨ true,             True)  -- "∧ binds more tightly than ∨"+              , (  (false ∧  true) ∨ true,             True)+              , (   false ∧ (true  ∨ true),            False)+              , (  (¬) true ∨ true,                    True)  -- "¬ binds more tightly than ∨"+              , (  (¬) (true ∨ true),                  False)+              ]++-- Example.++test06 :: Test+test06 = TestCase $ assertEqual "atoms test" (atoms $ p .&. q .|. s .=>. ((.~.) p) .|. (r .<=>. s)) (Set.fromList [P "p",P "q",P "r",P "s"])+    where (p, q, r, s) = (Atom (P "p"), Atom (P "q"), Atom (P "r"), Atom (P "s"))++-- Example.++test07 :: Test+test07 = TestCase $ assertEqual "truth table 1 (p. 36)" expected input+    where input = (truthTable $ p .&. q .=>. q .&. r)+          expected =+              (TruthTable+               [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"))++-- Additional examples illustrating formula classes.++test08 :: Test+test08 = TestCase $+    assertEqual "truth table 2 (p. 39)"+                (truthTable $  ((p .=>. q) .=>. p) .=>. p)+                (TruthTable+                 [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 = (TruthTable+                          [P "p"]+                          [([False],False),+                          ([True],False)])+              p = Atom (P "p")++-- Examples.++test10 :: Test+test10 = TestCase $ assertEqual "tautology 1 (p. 41)" True (tautology $ p .|. ((.~.) p)) where p = Atom (P "p")+test11 :: Test+test11 = TestCase $ assertEqual "tautology 2 (p. 41)" False (tautology $ p .|. q .=>. p) where (p, q) = (Atom (P "p"), Atom (P "q"))+test12 :: Test+test12 = TestCase $ assertEqual "tautology 3 (p. 41)" False (tautology $ p .|. q .=>. q .|. (p .<=>. q)) where (p, q) = (Atom (P "p"), Atom (P "q"))+test13 :: Test+test13 = TestCase $ assertEqual "tautology 4 (p. 41)" True (tautology $ (p .|. q) .&. ((.~.)(p .&. q)) .=>. ((.~.)p .<=>. q)) where (p, q) = (Atom (P "p"), Atom (P "q"))++-- | Substitution operation.+psubst :: JustPropositional formula => Map (AtomOf formula) formula -> formula -> formula+psubst subfn fm =+    foldPropositional co ne tf at fm+    where+      co p op q = binop (psubst subfn p) op (psubst subfn q)+      ne p = (.~.) (psubst subfn p)+      tf = fromBool+      at p = fromMaybe (atomic p) (fpf subfn p)++-- Example+test14 :: Test+test14 =+    TestCase $ assertEqual "pSubst (p. 41)" expected input+        where expected = (p .&. q) .&. q .&. (p .&. q) .&. q+              input = psubst ((P "p") |=> (p .&. q)) (p .&. q .&. p .&. q)+              (p, q) = (Atom (P "p"), Atom (P "q"))++-- Surprising tautologies including Dijkstra's "Golden rule".++test15 :: Test+test15 = TestCase $ assertEqual "tautology 5 (p. 43)" expected input+    where input = tautology $ (p .=>. q) .|. (q .=>. p)+          expected = True+          (p, q) = (Atom (P "p"), Atom (P "q"))+test16 :: Test+test16 = TestCase $ assertEqual "tautology 6 (p. 45)" expected input+    where input = tautology $ p .|. (q .<=>. r) .<=>. (p .|. q .<=>. p .|. r)+          expected = True+          (p, q, r) = (Atom (P "p"), Atom (P "q"), Atom (P "r"))+test17 :: Test+test17 = TestCase $ assertEqual "Dijkstra's Golden Rule (p. 45)" expected input+    where input = tautology $ p .&. q .<=>. ((p .<=>. q) .<=>. p .|. q)+          expected = True+          (p, q) = (Atom (P "p"), Atom (P "q"))+test18 :: Test+test18 = TestCase $ assertEqual "Contraposition 1 (p. 46)" expected input+    where input = tautology $ (p .=>. q) .<=>. (((.~.)q) .=>. ((.~.)p))+          expected = True+          (p, q) = (Atom (P "p"), Atom (P "q"))+test19 :: Test+test19 = TestCase $ assertEqual "Contraposition 2 (p. 46)" expected input+    where input = tautology $ (p .=>. ((.~.)q)) .<=>. (q .=>. ((.~.)p))+          expected = True+          (p, q) = (Atom (P "p"), Atom (P "q"))+test20 :: Test+test20 = TestCase $ assertEqual "Contraposition 3 (p. 46)" expected input+    where input = tautology $ (p .=>. q) .<=>. (q .=>. p)+          expected = False+          (p, q) = (Atom (P "p"), Atom (P "q"))++-- Some logical equivalences allowing elimination of connectives.++test21 :: Test+test21 = TestCase $ assertEqual "Equivalences (p. 47)" expected input+    where input =+              List.map tautology+              [ true .<=>. false .=>. false+              , ((.~.)p) .<=>. p .=>. false+              , p .&. q .<=>. (p .=>. q .=>. false) .=>. false+              , p .|. q .<=>. (p .=>. false) .=>. q+              , (p .<=>. q) .<=>. ((p .=>. q) .=>. (q .=>. p) .=>. false) .=>. false ]+          expected = [True, True, True, True, True]+          (p, q) = (Atom (P "p"), Atom (P "q"))++-- | Dualization.+dual :: JustPropositional pf => pf -> pf+dual fm =+    foldPropositional co ne tf (\_ -> fm) fm+    where+      tf True = false+      tf False = true+      ne p = (.~.) (dual p)+      co p (:&:) q = dual p .|. dual q+      co p (:|:) q = dual p .&. dual q+      co _ _ _ = error "Formula involves connectives .=>. or .<=>."++-- Example.+test22 :: Test+test22 = TestCase $ assertEqual "Dual (p. 49)" expected input+    where input = dual (Atom (P "p") .|. ((.~.) (Atom (P "p"))))+          expected = And (Atom (P {pname = "p"})) (Not (Atom (P {pname = "p"})))++-- | Routine simplification.+psimplify :: IsPropositional formula => formula -> formula+psimplify fm =+    foldPropositional' ho co ne tf at fm+    where+      ho _ = fm+      ne p = psimplify1 ((.~.) (psimplify p))+      co p (:&:) q = psimplify1 ((psimplify p) .&. (psimplify q))+      co p (:|:) q = psimplify1 ((psimplify p) .|. (psimplify q))+      co p (:=>:) q = psimplify1 ((psimplify p) .=>. (psimplify q))+      co p (:<=>:) q = psimplify1 ((psimplify p) .<=>. (psimplify q))+      tf _ = fm+      at _ = fm++psimplify1 :: IsPropositional formula => formula -> formula+psimplify1 fm =+    foldPropositional' (\_ -> fm) simplifyCombine simplifyNegate (\_ -> fm) (\_ -> fm) fm+    where+      simplifyNegate p = foldPropositional' (\_ -> fm) simplifyNotCombine simplifyNotNegate (fromBool . not) simplifyNotAtom p+      simplifyCombine l op r =+          case (asBool l, op , asBool r) of+            (Just True,  (:&:), _)            -> r+            (Just False, (:&:), _)            -> fromBool False+            (_,          (:&:), Just True)    -> l+            (_,          (:&:), Just False)   -> fromBool False+            (Just True,  (:|:), _)            -> fromBool True+            (Just False, (:|:), _)            -> r+            (_,          (:|:), Just True)    -> fromBool True+            (_,          (:|:), Just False)   -> l+            (Just True,  (:=>:), _)           -> r+            (Just False, (:=>:), _)           -> fromBool True+            (_,          (:=>:), Just True)   -> fromBool True+            (_,          (:=>:), Just False)  -> (.~.) l+            (Just False, (:<=>:), Just False) -> fromBool True+            (Just True,  (:<=>:), _)          -> r+            (Just False, (:<=>:), _)          -> (.~.) r+            (_,          (:<=>:), Just True)  -> l+            (_,          (:<=>:), Just False) -> (.~.) l+            _                                 -> fm+      simplifyNotNegate f = f+      simplifyNotCombine _ _ _ = fm+      simplifyNotAtom x = (.~.) (atomic x)++-- Example.+test23 :: Test+test23 = TestCase $ assertEqual "psimplify 1 (p. 50)" expected input+    where input = psimplify $ (true .=>. (x .<=>. false)) .=>. ((.~.) (y .|. false .&. z))+          expected = ((.~.) x) .=>. ((.~.) y)+          x = Atom (P "x")+          y = Atom (P "y")+          z = Atom (P "z")++test24 :: Test+test24 = TestCase $ assertEqual "psimplify 2 (p. 51)" expected input+    where input = psimplify $ ((x .=>. y) .=>. true) .|. (.~.) false+          expected = true+          x = Atom (P "x")+          y = Atom (P "y")++-- | Negation normal form.++nnf :: JustPropositional pf => pf -> pf+nnf = nnf1 . psimplify++nnf1 :: JustPropositional pf => pf -> pf+nnf1 fm = foldPropositional nnfCombine nnfNegate fromBool (\_ -> fm) fm+    where+      -- nnfCombine :: (IsPropositional formula atom) => formula -> Combination formula -> formula+      nnfNegate p = foldPropositional nnfNotCombine nnfNotNegate (fromBool . not) (\_ -> fm) p+      nnfCombine p (:=>:) q = nnf1 ((.~.) p) .|. (nnf1 q)+      nnfCombine p (:<=>:) q =  (nnf1 p .&. nnf1 q) .|. (nnf1 ((.~.) p) .&. nnf1 ((.~.) q))+      nnfCombine p (:&:) q = nnf1 p .&. nnf1 q+      nnfCombine p (:|:) q = nnf1 p .|. nnf1 q++      -- nnfNotCombine :: (IsPropositional formula atom) => Combination formula -> formula+      nnfNotNegate p = nnf1 p+      nnfNotCombine p (:&:) q = nnf1 ((.~.) p) .|. nnf1 ((.~.) q)+      nnfNotCombine p (:|:) q = nnf1 ((.~.) p) .&. nnf1 ((.~.) q)+      nnfNotCombine p (:=>:) q = nnf1 p .&. nnf1 ((.~.) q)+      nnfNotCombine p (:<=>:) q = (nnf1 p .&. nnf1 ((.~.) q)) .|. nnf1 ((.~.) p) .&. nnf1 q++-- Example of NNF function in action.++test25 :: Test+test25 = TestCase $ assertEqual "nnf 1 (p. 53)" expected input+    where input = nnf $ (p .<=>. q) .<=>. ((.~.)(r .=>. s))+          expected = Or (And (Or (And p q) (And (Not p) (Not q)))+                        (And r (Not s)))+                        (And (Or (And p (Not q)) (And (Not p) q))+                             (Or (Not r) s))+          p = Atom (P "p")+          q = Atom (P "q")+          r = Atom (P "r")+          s = Atom (P "s")++test26 :: Test+test26 = TestCase $ assertEqual "nnf 1 (p. 53)" expected input+    where input = tautology (Iff fm fm')+          expected = True+          fm' = nnf fm+          fm = (p .<=>. q) .<=>. ((.~.)(r .=>. s))+          p = Atom (P "p")+          q = Atom (P "q")+          r = Atom (P "r")+          s = Atom (P "s")++nenf :: IsPropositional formula => formula -> formula+nenf = nenf' . psimplify++-- | Simple negation-pushing when we don't care to distinguish occurrences.+nenf' :: IsPropositional formula => formula -> formula+nenf' fm =+    foldPropositional' (\_ -> fm) co ne (\_ -> fm) (\_ -> fm) fm+    where+      ne p = foldPropositional' (\_ -> fm) co' ne' (\_ -> fm) (\_ -> fm) p+      co p (:&:) q = nenf' p .&. nenf' q+      co p (:|:) q = nenf' p .|. nenf' q+      co p (:=>:) q = nenf' ((.~.) p) .|. nenf' q+      co p (:<=>:) q = nenf' p .<=>. nenf' q+      ne' p = p+      co' p (:&:) q = nenf' ((.~.) p) .|. nenf' ((.~.) q)+      co' p (:|:) q = nenf' ((.~.) p) .&. nenf' ((.~.) q)+      co' p (:=>:) q = nenf' p .&. nenf' ((.~.) q)+      co' p (:<=>:) q = nenf' p .<=>. nenf' ((.~.) q) -- really?  how is this asymmetrical?++-- Some tautologies remarked on.++test27 :: Test+test27 = TestCase $ assertEqual "tautology 1 (p. 53)" expected input+    where input = tautology $ (p .=>. p') .&. (q .=>. q') .=>. (p .&. q .=>. p' .&. q')+          expected = True+          p = Atom (P "p")+          q = Atom (P "q")+          p' = Atom (P "p'")+          q' = Atom (P "q'")+test28 :: Test+test28 = TestCase $ assertEqual "nnf 1 (p. 53)" expected input+    where input = tautology $ (p .=>. p') .&. (q .=>. q') .=>. (p .|. q .=>. p' .|. q')+          expected = True+          p = Atom (P "p")+          q = Atom (P "q")+          p' = Atom (P "p'")+          q' = Atom (P "q'")++dnfSet :: (JustPropositional pf, Ord pf) => pf -> pf+dnfSet fm =+    list_disj (List.map (mk_lits (Set.map atomic pvs)) satvals)+    where+      satvals = allsatvaluations (eval fm) (\_s -> False) pvs+      pvs = atoms fm++mk_lits :: (JustPropositional pf, Ord pf) => Set pf -> (AtomOf pf -> Bool) -> pf+mk_lits pvs v = list_conj (Set.map (\ p -> if eval p v then p else (.~.) p) pvs)++allsatvaluations :: Ord atom => ((atom -> Bool) -> Bool) -> (atom -> Bool) -> Set atom -> [atom -> Bool]+allsatvaluations subfn v pvs =+    case Set.minView pvs of+      Nothing -> if subfn v then [v] else []+      Just (p, ps) -> (allsatvaluations subfn (\a -> if a == p then False else v a) ps) +++                      (allsatvaluations subfn (\a -> if a == p then True else v a) ps)++-- | Disjunctive normal form (DNF) via truth tables.+list_conj :: (Foldable t, IsFormula formula, IsPropositional formula) => t formula -> formula+list_conj l | null l = true+list_conj l = foldl1 (.&.) l++list_disj :: (Foldable t, IsFormula formula, IsPropositional formula) => t formula -> formula+list_disj l | null l = false+list_disj l = foldl1 (.|.) l++-- This is only used in the test below, its easier to match lists than sets.+dnfList :: JustPropositional pf => pf -> pf+dnfList fm =+    list_disj (List.map (mk_lits' (List.map atomic (Set.toAscList pvs))) satvals)+     where+       satvals = allsatvaluations (eval fm) (\_s -> False) pvs+       pvs = atoms fm+       mk_lits' :: JustPropositional pf => [pf] -> (AtomOf pf -> Bool) -> pf+       mk_lits' pvs' v = list_conj (List.map (\ p -> if eval p v then p else (.~.) p) pvs')++-- Examples.++test29 :: Test+test29 = TestCase $ assertEqual "dnf 1 (p. 56)" expected input+    where input = (dnfList fm, truthTable fm)+          expected = ((((((.~.) p) .&. q) .&. r) .|. ((p .&. ((.~.) q)) .&. ((.~.) r))) .|. ((p .&. q) .&. ((.~.) r)),+                      TruthTable+                      [P "p", P "q", P "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, q, r) = (Atom (P "p"), Atom (P "q"), Atom (P "r"))++test30 :: Test+test30 = TestCase $ assertEqual "dnf 2 (p. 56)" expected input+    where input = dnfList (p .&. q .&. r .&. s .&. t .&. u .|. u .&. v :: PFormula Prop)+          expected = (((((((((((((((((((((((((((((((((((((((.~.) p) .&. ((.~.) q)) .&. ((.~.) r)) .&. ((.~.) s)) .&. ((.~.) t)) .&. u) .&. v) .|.+                                                    ((((((((.~.) p) .&. ((.~.) q)) .&. ((.~.) r)) .&. ((.~.) s)) .&. t) .&. u) .&. v)) .|.+                                                   ((((((((.~.) p) .&. ((.~.) q)) .&. ((.~.) r)) .&. s) .&. ((.~.) t)) .&. u) .&. v)) .|.+                                                  ((((((((.~.) p) .&. ((.~.) q)) .&. ((.~.) r)) .&. s) .&. t) .&. u) .&. v)) .|.+                                                 ((((((((.~.) p) .&. ((.~.) q)) .&. r) .&. ((.~.) s)) .&. ((.~.) t)) .&. u) .&. v)) .|.+                                                ((((((((.~.) p) .&. ((.~.) q)) .&. r) .&. ((.~.) s)) .&. t) .&. u) .&. v)) .|.+                                               ((((((((.~.) p) .&. ((.~.) q)) .&. r) .&. s) .&. ((.~.) t)) .&. u) .&. v)) .|.+                                              ((((((((.~.) p) .&. ((.~.) q)) .&. r) .&. s) .&. t) .&. u) .&. v)) .|.+                                             ((((((((.~.) p) .&. q) .&. ((.~.) r)) .&. ((.~.) s)) .&. ((.~.) t)) .&. u) .&. v)) .|.+                                            ((((((((.~.) p) .&. q) .&. ((.~.) r)) .&. ((.~.) s)) .&. t) .&. u) .&. v)) .|.+                                           ((((((((.~.) p) .&. q) .&. ((.~.) r)) .&. s) .&. ((.~.) t)) .&. u) .&. v)) .|.+                                          ((((((((.~.) p) .&. q) .&. ((.~.) r)) .&. s) .&. t) .&. u) .&. v)) .|.+                                         ((((((((.~.) p) .&. q) .&. r) .&. ((.~.) s)) .&. ((.~.) t)) .&. u) .&. v)) .|.+                                        ((((((((.~.) p) .&. q) .&. r) .&. ((.~.) s)) .&. t) .&. u) .&. v)) .|.+                                       ((((((((.~.) p) .&. q) .&. r) .&. s) .&. ((.~.) t)) .&. u) .&. v)) .|.+                                      ((((((((.~.) p) .&. q) .&. r) .&. s) .&. t) .&. u) .&. v)) .|.+                                     ((((((p .&. ((.~.) q)) .&. ((.~.) r)) .&. ((.~.) s)) .&. ((.~.) t)) .&. u) .&. v)) .|.+                                    ((((((p .&. ((.~.) q)) .&. ((.~.) r)) .&. ((.~.) s)) .&. t) .&. u) .&. v)) .|.+                                   ((((((p .&. ((.~.) q)) .&. ((.~.) r)) .&. s) .&. ((.~.) t)) .&. u) .&. v)) .|.+                                  ((((((p .&. ((.~.) q)) .&. ((.~.) r)) .&. s) .&. t) .&. u) .&. v)) .|.+                                 ((((((p .&. ((.~.) q)) .&. r) .&. ((.~.) s)) .&. ((.~.) t)) .&. u) .&. v)) .|.+                                ((((((p .&. ((.~.) q)) .&. r) .&. ((.~.) s)) .&. t) .&. u) .&. v)) .|.+                               ((((((p .&. ((.~.) q)) .&. r) .&. s) .&. ((.~.) t)) .&. u) .&. v)) .|.+                              ((((((p .&. ((.~.) q)) .&. r) .&. s) .&. t) .&. u) .&. v)) .|.+                             ((((((p .&. q) .&. ((.~.) r)) .&. ((.~.) s)) .&. ((.~.) t)) .&. u) .&. v)) .|.+                            ((((((p .&. q) .&. ((.~.) r)) .&. ((.~.) s)) .&. t) .&. u) .&. v)) .|.+                           ((((((p .&. q) .&. ((.~.) r)) .&. s) .&. ((.~.) t)) .&. u) .&. v)) .|.+                          ((((((p .&. q) .&. ((.~.) r)) .&. s) .&. t) .&. u) .&. v)) .|.+                         ((((((p .&. q) .&. r) .&. ((.~.) s)) .&. ((.~.) t)) .&. u) .&. v)) .|.+                        ((((((p .&. q) .&. r) .&. ((.~.) s)) .&. t) .&. u) .&. v)) .|.+                       ((((((p .&. q) .&. r) .&. s) .&. ((.~.) t)) .&. u) .&. v)) .|.+                      ((((((p .&. q) .&. r) .&. s) .&. t) .&. u) .&. ((.~.) v))) .|.+                     ((((((p .&. q) .&. r) .&. s) .&. t) .&. u) .&. v)+          [p, q, r, s, t, u, v] = List.map (Atom . P) ["p", "q", "r", "s", "t", "u", "v"]++-- | DNF via distribution.+distrib1 :: IsPropositional formula => formula -> formula+distrib1 fm =+    foldCombination (\_ -> fm) (\_ _ -> fm) lhs (\_ _ -> fm) (\_ _ -> fm) fm+    where+      -- p & (q | r) -> (p & q) | (p & r)+      lhs p qr = foldCombination (\_ -> rhs p qr)+                                 (\q r -> distrib1 (p .&. q) .|. distrib1 (p .&. r))+                                 (\_ _ -> rhs p qr)+                                 (\_ _ -> rhs p qr)+                                 (\_ _ -> rhs p qr)+                                 qr+      -- (p | q) & r -> (p & r) | (q & r)+      rhs pq r = foldCombination (\_ -> fm)+                                 (\p q -> distrib1 (p .&. r) .|. distrib1 (q .&. r))+                                 (\_ _ -> fm)+                                 (\_ _ -> fm)+                                 (\_ _ -> fm)+                                 pq+{-+distrib1 :: Formula atom -> Formula atom+distrib1 fm =+  case fm of+    And p (Or q r) -> Or (distrib1 (And p q)) (distrib1 (And p r))+    And (Or p q) r -> Or (distrib1 (And p r)) (distrib1 (And q r))+    _ -> fm+-}++rawdnf :: IsPropositional formula => formula -> formula+rawdnf fm =+    foldPropositional' (\_ -> fm) co (\_ -> fm) (\_ -> fm) (\_ -> fm) fm+    where+      co p (:&:) q = distrib1 (rawdnf p .&. rawdnf q)+      co p (:|:) q = (rawdnf p .|. rawdnf q)+      co _ _ _ = fm+{-+rawdnf :: Ord atom => Formula atom -> Formula atom+rawdnf fm =+  case fm of+    And p q -> distrib1 (And (rawdnf p) (rawdnf q))+    Or p q -> Or (rawdnf p) (rawdnf q)+    _ -> fm+-}++-- Example.++test31 :: Test+test31 = TestCase $ assertEqual "rawdnf (p. 58)" (prettyShow expected) (prettyShow input)+    where input :: PFormula Prop+          input = rawdnf $ (p .|. q .&. r) .&. (((.~.)p) .|. ((.~.)r))+          expected :: PFormula Prop+          expected = ((atomic (P "p")) .&. ((.~.)(atomic (P "p"))) .|.+                      ((atomic (P "q")) .&. (atomic (P "r"))) .&. ((.~.)(atomic (P "p")))) .|.+                     ((atomic (P "p")) .&. ((.~.)(atomic (P "r"))) .|.+                      ((atomic (P "q")) .&. (atomic (P "r"))) .&. ((.~.)(atomic (P "r"))))+          (p, q, r) = (Atom (P "p"), Atom (P "q"), Atom (P "r"))++purednf :: (JustPropositional pf,+            IsLiteral lit, JustLiteral lit, Ord lit) => (AtomOf pf -> AtomOf lit) -> pf -> Set (Set lit)+purednf ca fm =+    foldPropositional co (\_ -> l2f fm) (\_ -> l2f fm) (\_ -> l2f fm) fm+    where+      l2f f = singleton . singleton . convertToLiteral (error $ "purednf failure: " ++ prettyShow f) ca $ f+      co p (:&:) q = distrib (purednf ca p) (purednf ca q)+      co p (:|:) q = union (purednf ca p) (purednf ca q)+      co _ _ _ = l2f fm++-- Example.++test32 :: Test+test32 = TestCase $ assertEqual "purednf (p. 58)" expected (purednf id fm)+    where fm :: PFormula Prop+          fm = (p .|. q .&. r) .&. (((.~.)p) .|. ((.~.)r))+          expected :: Set (Set (LFormula Prop))+          expected = Set.map (Set.map (convertToLiteral (error "test32") id)) $+                     Set.fromList [Set.fromList [p, (.~.) p],+                                   Set.fromList [p, (.~.) r],+                                   Set.fromList [q, r, (.~.) p],+                                   Set.fromList [q, r, (.~.) r]]+          p = atomic (P "p")+          q = atomic (P "q")+          r = atomic (P "r")++-- | Filtering out trivial disjuncts (in this guise, contradictory).+trivial :: (Ord lit, IsLiteral lit) => Set lit -> Bool+trivial lits =+    let (pos, neg) = Set.partition positive lits in+    (not . null . Set.intersection neg . Set.map (.~.)) pos++-- Example.+test33 :: Test+test33 = TestCase $ assertEqual "trivial" expected (Set.filter (not . trivial) (purednf id fm))+    where expected :: Set (Set (LFormula Prop))+          expected = Set.map (Set.map (convertToLiteral (error "test32") id)) $+                     Set.fromList [Set.fromList [p,(.~.) r],+                                   Set.fromList [q,r,(.~.) p]]+          fm :: PFormula Prop+          fm = (p .|. q .&. r) .&. (((.~.)p) .|. ((.~.)r))+          p = atomic (P "p") :: PFormula Prop+          q = atomic (P "q") :: PFormula Prop+          r = atomic (P "r") :: PFormula Prop++-- | With subsumption checking, done very naively (quadratic).+simpdnf :: (JustPropositional pf,+            IsLiteral lit, JustLiteral lit, Ord lit+           ) => (AtomOf pf -> AtomOf lit) -> pf -> Set (Set lit)+simpdnf ca fm =+    foldPropositional (\_ _ _ -> go) (\_ -> go) tf (\_ -> go) fm+    where+      tf False = Set.empty+      tf True = singleton Set.empty+      go = let djs = Set.filter (not . trivial) (purednf ca (nnf fm)) in+           Set.filter (\d -> not (setAny (\d' -> Set.isProperSubsetOf d' d) djs)) djs++-- | Mapping back to a formula.+dnf :: forall pf. (JustPropositional pf, Ord pf) => pf -> pf+dnf fm = (list_disj . Set.toAscList . Set.map list_conj .+          Set.map (Set.map (convertLiteral id :: LFormula (AtomOf pf) -> pf)) . simpdnf id) fm++-- Example. (p. 56)+test34 :: Test+test34 = TestCase $ assertEqual "dnf (p. 56)" expected input+    where input = (prettyShow (dnf fm), tautology (Iff fm (dnf fm)))+          expected = ("(p∧¬r)∨(q∧r∧¬p)",True)+          fm = let (p, q, r) = (Atom (P "p"), Atom (P "q"), Atom (P "r")) in+               (p .|. q .&. r) .&. (((.~.)p) .|. ((.~.)r))++-- | Conjunctive normal form (CNF) by essentially the same code. (p. 60)+purecnf :: (JustPropositional pf, JustLiteral lit, Ord lit) =>+           (AtomOf pf -> AtomOf lit) -> pf -> Set (Set lit)+purecnf ca fm = Set.map (Set.map negate) (purednf ca (nnf ((.~.) fm)))++simpcnf :: (JustPropositional pf, JustLiteral lit, Ord lit) =>+           (AtomOf pf -> AtomOf lit) -> pf -> Set (Set lit)+simpcnf ca fm =+    foldPropositional (\_ _ _ -> go) (\_ -> go) tf (\_ -> go) fm+    where+      tf False = Set.empty+      tf True = singleton Set.empty+      go = let cjs = Set.filter (not . trivial) (purecnf ca fm) in+           Set.filter (\c -> not (setAny (\c' -> Set.isProperSubsetOf c' c) cjs)) cjs++cnf_ :: (IsPropositional pf, Ord pf, JustLiteral lit) => (AtomOf lit -> AtomOf pf) -> Set (Set lit) -> pf+cnf_ ca = list_conj . Set.map (list_disj . Set.map (convertLiteral ca))++cnf' :: forall pf. (JustPropositional pf, Ord pf) => pf -> pf+cnf' fm = (list_conj . Set.map list_disj . Set.map (Set.map (convertLiteral id :: LFormula (AtomOf pf) -> pf)) . simpcnf id) fm++-- Example. (p. 61)+test35 :: Test+test35 = TestCase $ assertEqual "cnf (p. 61)" expected input+    where input = (prettyShow (cnf' fm), tautology (Iff fm (cnf' fm)))+          expected = ("(p∨q)∧(p∨r)∧(¬p∨¬r)", True)+          fm = (p .|. q .&. r) .&. (((.~.)p) .|. ((.~.)r))+          [p, q, r] = [Atom (P "p"), Atom (P "q"), Atom (P "r")]++testProp :: Test+testProp = TestLabel "Prop" $+           TestList [test00, test01, test02, test03, test04, {-test05,-}+                     test06, test07, test08, test09, test10,+                     test11, test12, test13, test14, test15,+                     test16, test17, test18, test19, test20,+                     test21, test22, test23, test24, test25,+                     test26, test27, test28, test29, test30,+                     test31, test32, test33, test34, test35]
+ src/Data/Logic/ATP/PropExamples.hs view
@@ -0,0 +1,245 @@+-- | Some propositional formulas to test, and functions to generate classes.+--+-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Data.Logic.ATP.PropExamples+    ( Knows(K)+    , mk_knows, mk_knows2+    , prime+    , ramsey+    , testPropExamples+    ) where++import Data.Bits (Bits, shiftR)+import Data.List as List (map)+import Data.Logic.ATP.Formulas+import Data.Logic.ATP.Lib (allsets, timeMessage)+import Data.Logic.ATP.Lit ((.~.))+import Data.Logic.ATP.Pretty (HasFixity(precedence), Pretty(pPrint), prettyShow, text)+import Data.Logic.ATP.Prop+import Data.Set as Set+import Prelude hiding (sum)+import Test.HUnit++-- | Generate assertion equivalent to R(s,t) <= n for the Ramsey number R(s,t)+ramsey :: (IsPropositional pf, AtomOf pf ~ Knows Integer, Ord pf) =>+          Integer -> Integer -> Integer -> pf+ramsey s t n =+  let vertices = Set.fromList [1 .. n] in+  let yesgrps = Set.map (allsets (2 :: Integer)) (allsets s vertices)+      nogrps = Set.map (allsets (2 :: Integer)) (allsets t vertices) in+  let e xs = let [a, b] = Set.toAscList xs in atomic (K "p" a (Just b)) in+  list_disj (Set.map (list_conj . Set.map e) yesgrps) .|. list_disj (Set.map (list_conj . Set.map (\ p -> (.~.)(e p))) nogrps)++data Knows a = K String a (Maybe a) deriving (Eq, Ord, Show)++instance (Num a, Show a) => Pretty (Knows a) where+    pPrint (K s n mm) = text (s ++ show n ++ maybe "" (\ m -> "." ++ show m) mm)++instance Num a => HasFixity (Knows a) where+    precedence _ = 9++instance IsAtom (Knows Integer)++-- Some currently tractable examples. (p. 36)+test01 :: Test+test01 = TestList [TestCase (assertEqual "ramsey 3 3 4"+                                         "(p1.2∧p1.3∧p2.3)∨(p1.2∧p1.4∧p2.4)∨(p1.3∧p1.4∧p3.4)∨(p2.3∧p2.4∧p3.4)∨(¬p1.2∧¬p1.3∧¬p2.3)∨(¬p1.2∧¬p1.4∧¬p2.4)∨(¬p1.3∧¬p1.4∧¬p3.4)∨(¬p2.3∧¬p2.4∧¬p3.4)"+                                         -- "p1.2∧p1.3∧p2.3∨p1.2∧p1.4∧p2.4∨p1.3∧p1.4∧p3.4∨p2.3∧p2.4∧p3.4∨¬p1.2∧¬p1.3∧¬p2.3∨¬p1.2∧¬p1.4∧¬p2.4∨¬p1.3∧¬p1.4∧¬p3.4∨¬p2.3∧¬p2.4∧¬p3.4"+                                         (prettyShow (ramsey 3 3 4 :: PFormula (Knows Integer)))),+                   TestCase (timeMessage (\_ t -> "\nTime to compute (ramsey 3 3 5): " ++ show t) $ assertEqual "tautology (ramsey 3 3 5)" False (tautology (ramsey 3 3 5 :: PFormula (Knows Integer)))),+                   TestCase (timeMessage (\_ t -> "\nTime to compute (ramsey 3 3 6): " ++ show t) $ assertEqual "tautology (ramsey 3 3 6)" True (tautology (ramsey 3 3 6 :: PFormula (Knows Integer))))]++-- | Half adder.  (p. 66)+halfsum :: forall formula. IsPropositional formula => formula -> formula -> formula+halfsum x y = x .<=>. ((.~.) y)++halfcarry :: forall formula. IsPropositional formula => formula -> formula -> formula+halfcarry x y = x .&. y++ha :: forall formula. IsPropositional formula => formula -> formula -> formula -> formula -> formula+ha x y s c = (s .<=>. halfsum x y) .&. (c .<=>. halfcarry x y)++-- | Full adder.+carry :: forall formula. IsPropositional formula => formula -> formula -> formula -> formula+carry x y z = (x .&. y) .|. ((x .|. y) .&. z)++sum :: forall formula. IsPropositional formula => formula -> formula -> formula -> formula+sum x y z = halfsum (halfsum x y) z++fa :: forall formula. IsPropositional 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 :: (IsPropositional formula, Ord formula, Ord a) => (a -> formula) -> 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.  (p. 67)+ripplecarry :: (IsPropositional formula, Ord formula, Ord a, 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_knows :: (IsPropositional formula, AtomOf formula ~ Knows a) => String -> a -> formula+mk_knows x i = atomic (K x i Nothing)+mk_knows2 :: (IsPropositional formula, AtomOf formula ~ Knows a) => String -> a -> a -> formula+mk_knows2 x i j = atomic (K x i (Just j))++test02 :: Test+test02 =+    let [x, y, out, c] = List.map mk_knows ["X", "Y", "OUT", "C"] :: [Integer -> PFormula (Knows Integer)] in+    TestCase (assertEqual "ripplecarry x y c out 2"+                          (((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)))))+                          (ripplecarry x y c out 2 :: PFormula (Knows Integer)))++-- | Special case with 0 instead of c(0).+ripplecarry0 :: (IsPropositional formula, 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 :: (IsPropositional formula, 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. IsPropositional 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 :: (IsPropositional formula, Ord formula, Ord a, 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. (p. 69)+mk_adder_test :: (IsPropositional formula, Ord formula, AtomOf formula ~ Knows a, Ord a, Num a, Enum a) =>+                 a -> a -> formula+mk_adder_test n k =+  let [x, y, c, s, c0, s0, c1, s1, c2, s2] =+          List.map mk_knows ["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.  (p. 70)+--+--       UUUUUUUUUUUUUUUUUUUU  (u)+--    +  VVVVVVVVVVVVVVVVVVVV  (v)+--+--    = WWWWWWWWWWWWWWWWWWWW   (w)+--    +                     Z  (z)++rippleshift :: (IsPropositional formula, Ord formula, Ord a, 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 :: (IsPropositional formula, Ord formula, Ord a, 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. (p. 71)+--+-- For large examples, should use 'Integer' instead of 'Int' in these functions.+bitlength :: forall b a. (Num a, Num b, Bits b) => b -> a+bitlength x = if x == 0 then 0 else 1 + bitlength (shiftR x 1);;++bit :: forall a b. (Num a, Eq a, Bits b, Integral b) => a -> b -> Bool+bit n x = if n == 0 then x `mod` 2 == 1 else bit (n - 1) (shiftR x 1)++congruent_to :: (IsPropositional formula, Ord formula, Bits b, Ord a, 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 :: (IsPropositional formula, Ord formula, AtomOf formula ~ Knows Integer) => Integer -> formula+prime p =+  let [x, y, out] = List.map mk_knows ["x", "y", "out"] in+  let m i j = (x i) .&. (y j)+      [u, v] = List.map mk_knows2 ["u", "v"] in+  let (n :: Integer) = bitlength p in+  (.~.) (multiplier m u v out (n - 1) .&. congruent_to out p (max n (2 * n - 2)))++-- Examples. (p. 72)++type F = PFormula (Knows Integer)++test03 :: Test+test03 =+    TestList [TestCase (timeMessage (\_ t -> "\nTime to prove (prime 7): " ++ show t)  (assertEqual "tautology(prime 7)" True (tautology (prime 7 :: F)))),+              TestCase (timeMessage (\_ t -> "\nTime to prove (prime 9): " ++ show t)  (assertEqual "tautology(prime 9)" False (tautology (prime 9 :: F)))),+              TestCase (timeMessage (\_ t -> "\nTime to prove (prime 11): " ++ show t) (assertEqual "tautology(prime 11)" True (tautology (prime 11 :: F))))]++testPropExamples :: Test+testPropExamples = TestLabel "PropExamples" (TestList [test01, test02, test03])
+ src/Data/Logic/ATP/Quantified.hs view
@@ -0,0 +1,281 @@+-- | 'IsQuantified' is a subclass of 'IsPropositional' of formula+-- types that support existential and universal quantification.++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Logic.ATP.Quantified+    ( Quant((:!:), (:?:))+    , IsQuantified(VarOf, quant, foldQuantified)+    , for_all, (∀)+    , exists, (∃)+    , precedenceQuantified+    , associativityQuantified+    , prettyQuantified+    , showQuantified+    , zipQuantified+    , convertQuantified+    , onatomsQuantified+    , overatomsQuantified+    -- * Concrete instance of a quantified formula type+    , QFormula(F, T, Atom, Not, And, Or, Imp, Iff, Forall, Exists)+    ) where++import Data.Data (Data)+import Data.Logic.ATP.Apply (HasApply(TermOf))+import Data.Logic.ATP.Formulas (fromBool, IsAtom, IsFormula(..), onatoms, prettyBool)+import Data.Logic.ATP.Lit ((.~.), IsLiteral(foldLiteral'), IsLiteral(..))+import Data.Logic.ATP.Pretty as Pretty+    ((<>), Associativity(InfixN, InfixR, InfixA), Doc, HasFixity(precedence, associativity),+     Precedence, Side(Top, LHS, RHS, Unary), testParen, text,+     andPrec, orPrec, impPrec, iffPrec, notPrec, leafPrec, quantPrec)+import Data.Logic.ATP.Prop (BinOp(..), binop, IsPropositional((.&.), (.|.), (.=>.), (.<=>.), foldPropositional', foldCombination))+import Data.Logic.ATP.Term (IsTerm(TVarOf), IsVariable)+import Data.Typeable (Typeable)+import Prelude hiding (pred)+import Text.PrettyPrint (fsep)+import Text.PrettyPrint.HughesPJClass (maybeParens, Pretty(pPrint, pPrintPrec), PrettyLevel, prettyNormal)++-------------------------+-- QUANTIFIED FORMULAS --+-------------------------++-- | The two types of quantification+data Quant+    = (:!:) -- ^ for_all+    | (:?:) -- ^ exists+    deriving (Eq, Ord, Data, Typeable, Show)++-- | Class of quantified formulas.+class (IsPropositional formula, IsVariable (VarOf formula)) => IsQuantified formula where+    type (VarOf formula) -- A type function mapping formula to the associated variable+    quant :: Quant -> VarOf formula -> formula -> formula+    foldQuantified :: (Quant -> VarOf formula -> formula -> r)+                   -> (formula -> BinOp -> formula-> r)+                   -> (formula -> r)+                   -> (Bool -> r)+                   -> (AtomOf formula -> r)+                   -> formula -> r++for_all :: IsQuantified formula => VarOf formula -> formula -> formula+for_all = quant (:!:)+exists :: IsQuantified formula => VarOf formula -> formula -> formula+exists = quant (:?:)++-- | ∀ can't be a function when -XUnicodeSyntax is enabled.+(∀) :: IsQuantified formula => VarOf formula -> formula -> formula+infixr 1 ∀+(∀) = for_all+(∃) :: IsQuantified formula => VarOf formula -> formula -> formula+infixr 1 ∃+(∃) = exists++precedenceQuantified :: forall formula. IsQuantified formula => formula -> Precedence+precedenceQuantified = foldQuantified qu co ne tf at+    where+      qu _ _ _ = quantPrec+      co _ (:&:) _ = andPrec+      co _ (:|:) _ = orPrec+      co _ (:=>:) _ = impPrec+      co _ (:<=>:) _ = iffPrec+      ne _ = notPrec+      tf _ = leafPrec+      at = precedence++associativityQuantified :: forall formula. IsQuantified formula => formula -> Associativity+associativityQuantified = foldQuantified qu co ne tf at+    where+      qu _ _ _ = Pretty.InfixR+      ne _ = Pretty.InfixA+      co _ (:&:) _ = Pretty.InfixA+      co _ (:|:) _ = Pretty.InfixA+      co _ (:=>:) _ = Pretty.InfixR+      co _ (:<=>:) _ = Pretty.InfixA+      tf _ = Pretty.InfixN+      at = associativity++-- | Implementation of 'Pretty' for 'IsQuantified' types.+prettyQuantified :: forall fof v. (IsQuantified fof, v ~ VarOf fof) =>+                    Side -> PrettyLevel -> Rational -> fof -> Doc+prettyQuantified side l r fm =+    maybeParens (l > prettyNormal || testParen side r (precedence fm) (associativity fm)) $ foldQuantified (\op v p -> qu op [v] p) co ne tf at fm+    -- maybeParens (r > precedence fm) $ foldQuantified (\op v p -> qu op [v] p) co ne tf at fm+    where+      -- Collect similarly quantified variables+      qu :: Quant -> [v] -> fof -> Doc+      qu op vs p' = foldQuantified (qu' op vs p') (\_ _ _ -> qu'' op vs p') (\_ -> qu'' op vs p')+                                                      (\_ -> qu'' op vs p') (\_ -> qu'' op vs p') p'+      qu' :: Quant -> [v] -> fof -> Quant -> v -> fof -> Doc+      qu' op vs _ op' v p' | op == op' = qu op (v : vs) p'+      qu' op vs p _ _ _ = qu'' op vs p+      qu'' :: Quant -> [v] -> fof -> Doc+      qu'' _op [] p = prettyQuantified Unary l r p+      qu'' op vs p = text (case op of (:!:) -> "∀"; (:?:) -> "∃") <>+                     fsep (map pPrint (reverse vs)) <>+                     text ". " <> prettyQuantified Unary l (precedence fm + 1) p+      co :: fof -> BinOp -> fof -> Doc+      co p (:&:) q = prettyQuantified LHS l (precedence fm) p <> text "∧" <>  prettyQuantified RHS l (precedence fm) q+      co p (:|:) q = prettyQuantified LHS l (precedence fm) p <> text "∨" <> prettyQuantified RHS l (precedence fm) q+      co p (:=>:) q = prettyQuantified LHS l (precedence fm) p <> text "⇒" <> prettyQuantified RHS l (precedence fm) q+      co p (:<=>:) q = prettyQuantified LHS l (precedence fm) p <> text "⇔" <> prettyQuantified RHS l (precedence fm) q+      ne p = text "¬" <> prettyQuantified Unary l (precedence fm) p+      tf x = prettyBool x+      at x = pPrintPrec l r x -- maybeParens (d > PrettyLevel atomPrec) $ pPrint x++-- | Implementation of 'showsPrec' for 'IsQuantified' types.+showQuantified :: IsQuantified formula => Side -> Int -> formula -> ShowS+showQuantified side r fm =+    showParen (testParen side r (precedence fm) (associativity fm)) $ foldQuantified qu co ne tf at fm+    where+      qu (:!:) x p = showString "for_all " . showString (show x) . showString " " . showQuantified Unary (precedence fm + 1) p+      qu (:?:) x p = showString "exists " . showString (show x) . showString " " . showQuantified Unary (precedence fm + 1) p+      co p (:&:) q = showQuantified LHS (precedence fm) p . showString " .&. " . showQuantified RHS (precedence fm) q+      co p (:|:) q = showQuantified LHS (precedence fm) p . showString " .|. " . showQuantified RHS (precedence fm) q+      co p (:=>:) q = showQuantified LHS (precedence fm) p . showString " .=>. " . showQuantified RHS (precedence fm) q+      co p (:<=>:) q = showQuantified LHS (precedence fm) p . showString " .<=>. " . showQuantified RHS (precedence fm) q+      ne p = showString "(.~.) " . showQuantified Unary (succ (precedence fm)) p+      tf x = showsPrec (precedence fm) x+      at x = showsPrec (precedence fm) x++-- | Combine two formulas if they are similar.+zipQuantified :: IsQuantified formula =>+                 (Quant -> VarOf formula -> formula -> Quant -> VarOf formula -> formula -> Maybe r)+              -> (formula -> BinOp -> formula -> formula -> BinOp -> formula -> Maybe r)+              -> (formula -> formula -> Maybe r)+              -> (Bool -> Bool -> Maybe r)+              -> ((AtomOf formula) -> (AtomOf formula) -> Maybe r)+              -> formula -> formula -> Maybe r+zipQuantified qu co ne tf at fm1 fm2 =+    foldQuantified qu' co' ne' tf' at' fm1+    where+      qu' op1 v1 p1 = foldQuantified (qu op1 v1 p1)       (\ _ _ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) fm2+      co' l1 op1 r1 = foldQuantified (\ _ _ _ -> Nothing) (co l1 op1 r1)       (\ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) fm2+      ne' x1 =        foldQuantified (\ _ _ _ -> Nothing) (\ _ _ _ -> Nothing) (ne x1)          (\ _ -> Nothing) (\ _ -> Nothing) fm2+      tf' x1 =        foldQuantified (\ _ _ _ -> Nothing) (\ _ _ _ -> Nothing) (\ _ -> Nothing) (tf x1)          (\ _ -> Nothing) fm2+      at' atom1 =     foldQuantified (\ _ _ _ -> Nothing) (\ _ _ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) (at atom1)       fm2++-- | Convert any instance of IsQuantified to any other by+-- specifying the result type.+convertQuantified :: forall f1 f2.+                     (IsQuantified f1, IsQuantified f2) =>+                     (AtomOf f1 -> AtomOf f2) -> (VarOf f1 -> VarOf f2) -> f1 -> f2+convertQuantified ca cv f1 =+    foldQuantified qu co ne tf at f1+    where+      qu :: Quant -> VarOf f1 -> f1 -> f2+      qu (:!:) x p = for_all (cv x :: VarOf f2) (convertQuantified ca cv p :: f2)+      qu (:?:) x p = exists (cv x :: VarOf f2) (convertQuantified ca cv p :: f2)+      co p (:&:) q = convertQuantified ca cv p .&. convertQuantified ca cv q+      co p (:|:) q = convertQuantified ca cv p .|. convertQuantified ca cv q+      co p (:=>:) q = convertQuantified ca cv p .=>. convertQuantified ca cv q+      co p (:<=>:) q = convertQuantified ca cv p .<=>. convertQuantified ca cv q+      ne p = (.~.) (convertQuantified ca cv p)+      tf :: Bool -> f2+      tf = fromBool+      at :: AtomOf f1 -> f2+      at = atomic . ca++onatomsQuantified :: IsQuantified formula => (AtomOf formula -> AtomOf formula) -> formula -> formula+onatomsQuantified f fm =+    foldQuantified qu co ne tf at fm+    where+      qu op v p = quant op v (onatomsQuantified f p)+      ne p = (.~.) (onatomsQuantified f p)+      co p op q = binop (onatomsQuantified f p) op (onatomsQuantified f q)+      tf flag = fromBool flag+      at x = atomic (f x)++overatomsQuantified :: IsQuantified fof => (AtomOf fof -> r -> r) -> fof -> r -> r+overatomsQuantified f fof r0 =+    foldQuantified qu co ne (const r0) (flip f r0) fof+    where+      qu _ _ fof' = overatomsQuantified f fof' r0+      ne fof' = overatomsQuantified f fof' r0+      co p _ q = overatomsQuantified f p (overatomsQuantified f q r0)++data QFormula v atom+    = F+    | T+    | Atom atom+    | Not (QFormula v atom)+    | And (QFormula v atom) (QFormula v atom)+    | Or (QFormula v atom) (QFormula v atom)+    | Imp (QFormula v atom) (QFormula v atom)+    | Iff (QFormula v atom) (QFormula v atom)+    | Forall v (QFormula v atom)+    | Exists v (QFormula v atom)+    deriving (Eq, Ord, Data, Typeable, Read)++instance (HasApply atom, IsTerm term, term ~ TermOf atom, v ~ TVarOf term) => Pretty (QFormula v atom) where+    pPrintPrec = prettyQuantified Top++-- The IsFormula instance for QFormula+instance (HasApply atom, v ~ TVarOf (TermOf atom)) => IsFormula (QFormula v atom) where+    type AtomOf (QFormula v atom) = atom+    asBool T = Just True+    asBool F = Just False+    asBool _ = Nothing+    true = T+    false = F+    atomic = Atom+    overatoms = overatomsQuantified+    onatoms = onatomsQuantified++instance (IsFormula (QFormula v atom), HasApply atom, v ~ TVarOf (TermOf atom)) => IsPropositional (QFormula v atom) where+    (.|.) = Or+    (.&.) = And+    (.=>.) = Imp+    (.<=>.) = Iff+    foldPropositional' ho co ne tf at fm =+        case fm of+          And p q -> co p (:&:) q+          Or p q -> co p (:|:) q+          Imp p q -> co p (:=>:) q+          Iff p q -> co p (:<=>:) q+          _ -> foldLiteral' ho ne tf at fm+    foldCombination other dj cj imp iff fm =+        case fm of+          Or a b -> a `dj` b+          And a b -> a `cj` b+          Imp a b -> a `imp` b+          Iff a b -> a `iff` b+          _ -> other fm++instance (IsPropositional (QFormula v atom), IsVariable v, IsAtom atom) => IsQuantified (QFormula v atom) where+    type VarOf (QFormula v atom) = v+    quant (:!:) = Forall+    quant (:?:) = Exists+    foldQuantified qu _co _ne _tf _at (Forall v fm) = qu (:!:) v fm+    foldQuantified qu _co _ne _tf _at (Exists v fm) = qu (:?:) v fm+    foldQuantified _qu co ne tf at fm =+        foldPropositional' (\_ -> error "IsQuantified QFormula") co ne tf at fm++-- Build a Haskell expression for this formula+instance IsQuantified (QFormula v atom) => Show (QFormula v atom) where+    showsPrec = showQuantified Top++-- Precedence information for QFormula+instance IsQuantified (QFormula v atom) => HasFixity (QFormula v atom) where+    precedence = precedenceQuantified+    associativity = associativityQuantified++instance (HasApply atom, v ~ TVarOf (TermOf atom)) => IsLiteral (QFormula v atom) where+    naiveNegate = Not+    foldNegation normal inverted (Not x) = foldNegation inverted normal x+    foldNegation normal _ x = normal x+    foldLiteral' ho ne tf at fm =+        case fm of+          T -> tf True+          F -> tf False+          Atom a -> at a+          Not p -> ne p+          _ -> ho fm
+ src/Data/Logic/ATP/Resolution.hs view
@@ -0,0 +1,1115 @@+-- | Resolution.+--+-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}++module Data.Logic.ATP.Resolution+    ( match_atoms+    , match_atoms_eq+    , resolution1+    , resolution2+    , resolution3+    , presolution+    -- , matchAtomsEq+    , davis_putnam_example_formula+    , testResolution+    ) where++import Control.Monad.State (execStateT, get, StateT)+import Data.List as List (map)+import Data.Logic.ATP.Apply (HasApply(TermOf), JustApply, pApp, zipApplys)+import Data.Logic.ATP.Equate (HasEquate, zipEquates)+import Data.Logic.ATP.FOL (generalize, IsFirstOrder, lsubst, var)+import Data.Logic.ATP.Formulas (IsFormula(AtomOf))+import Data.Logic.ATP.Lib (allpairs, allsubsets, allnonemptysubsets, apply, defined,+                           Failing(..), failing, (|->), setAll, setAny, settryfind)+import Data.Logic.ATP.Lit ((.~.), IsLiteral, JustLiteral, LFormula, positive, zipLiterals')+import Data.Logic.ATP.Pretty (assertEqual', Pretty, prettyShow)+import Data.Logic.ATP.Prop ((.|.), (.&.), (.=>.), (.<=>.), list_conj, PFormula, simpcnf, trivial)+import Data.Logic.ATP.Quantified (exists, for_all, IsQuantified(VarOf))+import Data.Logic.ATP.Parser (fof)+import Data.Logic.ATP.Skolem (askolemize, Formula, Function(Skolem), HasSkolem(SVarOf), pnf,+                              runSkolem, simpdnf', SkAtom, skolemize, SkolemT, specialize, SkTerm)+import Data.Logic.ATP.Term (fApp, foldTerm, IsTerm(FunOf, TVarOf), prefix, V, vt)+import Data.Logic.ATP.Unif (solve, Unify, unify_literals)+import Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Set as Set+import Data.String (fromString)+import Test.HUnit++-- | Barber's paradox is an example of why we need factoring.+test01 :: Test+test01 = TestCase $ assertEqual ("Barber's paradox: " ++ prettyShow barb ++ " (p. 181)")+                    (prettyShow expected)+                    (prettyShow input)+    where shaves = pApp "shaves" :: [SkTerm] -> Formula+          [b, x] = [vt "b", vt "x"] :: [SkTerm]+          fx = fApp (Skolem "x" 1) :: [SkTerm] -> SkTerm+          barb = exists "b" (for_all "x" (shaves [b, x] .<=>. (.~.)(shaves [x, x]))) :: Formula+          input :: Set (Set (LFormula SkAtom))+          input = simpcnf id (runSkolem (skolemize id ((.~.)barb)) :: PFormula SkAtom)+          -- This is not exactly what is in the book+          expected :: Set (Set Formula)+          expected = Set.fromList [Set.fromList [shaves [b,     fx [b]], (.~.)(shaves [fx [b],fx [b]])],+                                   Set.fromList [shaves [fx [b],fx [b]], (.~.)(shaves [b,     fx [b]])]]+          -- x = vt (fromString "x")+          -- b = vt (fromString "b")+          -- fx = fApp (Skolem "x" 1)++-- | MGU of a set of literals.+mgu :: forall lit atom term v.+       (IsLiteral lit, HasApply atom, Unify atom v term, IsTerm term,+        atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+       Set lit -> StateT (Map v term) Failing (Map v term)+mgu l =+    case Set.minView l of+      Just (a, rest) ->+          case Set.minView rest of+            Just (b, _) -> unify_literals a b >> mgu rest+            _ -> solve <$> get+      _ -> solve <$> get++unifiable :: (IsLiteral lit, IsTerm term, HasApply atom, Unify atom v term,+              atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+             lit -> lit -> Bool+unifiable p q = failing (const False) (const True) (execStateT (unify_literals p q) Map.empty)++-- -------------------------------------------------------------------------+-- Rename a clause.+-- -------------------------------------------------------------------------++rename :: (JustLiteral lit, Ord lit, HasApply atom, IsTerm term,+           atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+          (v -> v) -> Set lit -> Set lit+rename pfx cls =+    Set.map (lsubst (Map.fromList (Set.toList (Set.map (\v -> (v, (vt (pfx v)))) fvs)))) cls+    where+      fvs = Set.fold Set.union Set.empty (Set.map var cls)++-- -------------------------------------------------------------------------+-- General resolution rule, incorporating factoring as in Robinson's paper.+-- -------------------------------------------------------------------------++resolvents :: (JustLiteral lit, Ord lit, HasApply atom, Unify atom v term, IsTerm term,+               atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+              Set lit -> Set lit -> lit -> Set lit -> Set lit+resolvents cl1 cl2 p acc =+    if Set.null ps2 then acc else Set.fold doPair acc pairs+    where+      doPair (s1,s2) sof =+          case execStateT (mgu (Set.union s1 (Set.map (.~.) s2))) Map.empty of+            Success mp -> Set.union (Set.map (lsubst mp) (Set.union (Set.difference cl1 s1) (Set.difference cl2 s2))) sof+            Failure _ -> sof+      -- pairs :: Set (Set fof, Set fof)+      pairs = allpairs (,) (Set.map (Set.insert p) (allsubsets ps1)) (allnonemptysubsets ps2)+      -- ps1 :: Set fof+      ps1 = Set.filter (\ q -> q /= p && unifiable p q) cl1+      -- ps2 :: Set fof+      ps2 = Set.filter (unifiable ((.~.) p)) cl2++resolve_clauses :: (JustLiteral lit, Ord lit, HasApply atom, Unify atom v term, IsTerm term,+                    atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+                   Set lit -> Set lit -> Set lit+resolve_clauses cls1 cls2 =+    let cls1' = rename (prefix "x") cls1+        cls2' = rename (prefix "y") cls2 in+    Set.fold (resolvents cls1' cls2') Set.empty cls1'++-- -------------------------------------------------------------------------+-- Basic "Argonne" loop.+-- -------------------------------------------------------------------------++resloop1 :: (JustLiteral lit, Ord lit, HasApply atom, IsTerm term, Unify atom v term,+             atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+            Set (Set lit) -> Set (Set lit) -> Failing Bool+resloop1 used unused =+    maybe (Failure ["No proof found"]) step (Set.minView unused)+    where+      step (cl, ros) =+          if Set.member Set.empty news then return True else resloop1 used' (Set.union ros news)+          where+            used' = Set.insert cl used+            -- resolve_clauses is not in the Failing monad, so setmapfilter isn't appropriate.+            news = Set.fold Set.insert Set.empty ({-setmapfilter-} Set.map (resolve_clauses cl) used')++pure_resolution1 :: forall fof atom term v.+                    (atom ~ AtomOf fof, term ~ TermOf atom, v ~ TVarOf term,+                     IsFirstOrder fof,+                     Unify atom v term,+                     Ord fof, Pretty fof+                    ) => fof -> Failing Bool+pure_resolution1 fm = resloop1 Set.empty (simpcnf id (specialize id (pnf fm) :: PFormula atom) :: Set (Set (LFormula atom)))++resolution1 :: forall m fof atom term v function.+               (IsFirstOrder fof, Unify atom v term, Ord fof, HasSkolem function, Monad m,+                atom ~ AtomOf fof, term ~ TermOf atom, function ~ FunOf term, v ~ TVarOf term, v ~ SVarOf function) =>+               fof -> SkolemT m function (Set (Failing Bool))+resolution1 fm = askolemize ((.~.)(generalize fm)) >>= return . Set.map (pure_resolution1 . list_conj) . (simpdnf' :: fof -> Set (Set fof))++-- | Simple example that works well.+davis_putnam_example_formula :: Formula+davis_putnam_example_formula = [fof| ∃ x y. (∀ z. ((F(x,y)⇒F(y,z)∧F(z,z))∧(F(x,y)∧G(x,y)⇒G(x,z)∧G(z,z)))) |]+{-+    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, y, z] = [vt "x", vt "y", vt "z"] :: [SkTerm]+      [g, f] = [pApp "G", pApp "F"] :: [[SkTerm] -> Formula]+-}+test02 :: Test+test02 =+    TestCase $ assertEqual "Davis-Putnam example 1" expected (runSkolem (resolution1 davis_putnam_example_formula))+        where+          expected = Set.singleton (Success True)++-- -------------------------------------------------------------------------+-- Matching of terms and literals.+-- -------------------------------------------------------------------------++class Match a v term where+    match :: Map v term -> a -> Failing (Map v term)++match_terms :: forall term v. (IsTerm term, v ~ TVarOf term) => Map v term -> [(term, term)] -> Failing (Map v term)+match_terms env [] = Success env+match_terms env ((p, q) : oth) =+    foldTerm vr fn p+    where+      vr x | not (defined env x) = match_terms ((x |-> q) env) oth+           | apply env x == Just q = match_terms env oth+           | otherwise = fail "match_terms"+      fn f fa =+          foldTerm vr' fn' q+          where+            fn' g ga | f == g && length fa == length ga = match_terms env (zip fa ga ++ oth)+            fn' _ _ = fail "match_terms"+            vr' _ = fail "match_terms"++match_atoms :: (JustApply atom, IsTerm term, term ~ TermOf atom, v ~ TVarOf term) =>+               Map v term -> (atom, atom) -> Failing (Map v term)+match_atoms env (a1, a2) =+    maybe (Failure ["match_atoms"]) id (zipApplys (\_ pairs -> Just (match_terms env pairs)) a1 a2)++match_atoms_eq :: (HasEquate atom, IsTerm term, term ~ TermOf atom, v ~ TVarOf term) =>+                  Map v term -> (atom, atom) -> Failing (Map v term)+match_atoms_eq env (a1, a2) =+    maybe (Failure ["match_atoms_eq"]) id (zipEquates (\l1 r1 l2 r2 -> Just (match_terms env [(l1, l2), (r1, r2)]))+                                                      (\_ pairs -> Just (match_terms env pairs)) a1 a2)++match_literals :: forall lit atom term v.+                  (IsLiteral lit, HasApply atom, IsTerm term, Match (atom, atom) v term,+                   atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+                  Map v term -> lit -> lit -> Failing (Map v term)+match_literals env t1 t2 =+    fromMaybe (fail "match_literals") (zipLiterals' ho ne tf at t1 t2)+    where+      ho _ _ = Nothing+      ne p q = Just $ match_literals env p q+      tf a b = if a == b then Just (Success env) else Nothing+      at a1 a2 = Just (match env (a1, a2))++-- | With deletion of tautologies and bi-subsumption with "unused".+resolution2 :: forall fof atom term v function m.+               (IsFirstOrder fof, Unify atom v term, Match (atom, atom) v term, HasSkolem function, Monad m, Ord fof,+                atom ~ AtomOf fof, term ~ TermOf atom, function ~ FunOf term, v ~ TVarOf term, v ~ SVarOf function) =>+               fof -> SkolemT m function (Set (Failing Bool))+resolution2 fm = askolemize ((.~.) (generalize fm)) >>= return . Set.map (pure_resolution2 . list_conj) . (simpdnf' :: fof -> Set (Set fof))++pure_resolution2 :: forall fof atom term v.+                    (IsFirstOrder fof, Ord fof, Pretty fof,+                     HasApply atom, IsTerm term,+                     Unify atom v term, Match (atom, atom) v term,+                     atom ~ AtomOf fof, term ~ TermOf atom, v ~ TVarOf term) =>+                    fof -> Failing Bool+pure_resolution2 fm = resloop2 Set.empty (simpcnf id (specialize id (pnf fm) :: PFormula atom) :: Set (Set (LFormula atom)))++resloop2 :: (JustLiteral lit, Ord lit, HasApply atom, IsTerm term,+             Unify atom v term, Match (atom, atom) v term,+             atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+            Set (Set lit) -> Set (Set lit) -> Failing Bool+resloop2 used unused =+    case Set.minView unused of+      Nothing -> Failure ["No proof found"]+      Just (cl, ros) ->+          -- print_string(string_of_int(length used) ^ " used; "^ string_of_int(length unused) ^ " unused.");+          -- print_newline();+          let used' = Set.insert cl used in+          let news = Set.map (resolve_clauses cl) used' in+          if Set.member Set.empty news then return True else resloop2 used' (Set.fold (incorporate cl) ros news)++incorporate :: (atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term,+                IsLiteral lit, Ord lit,+                HasApply atom, Match (atom, atom) v term,+                IsTerm term) =>+               Set lit+            -> Set lit+            -> Set (Set lit)+            -> Set (Set lit)+incorporate gcl cl unused =+    if trivial cl || setAny (\ c -> subsumes_clause c cl) (Set.insert gcl unused)+    then unused+    else replace cl unused++replace :: (atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term,+            IsLiteral lit, Ord lit,+            IsTerm term,+            HasApply atom, Match (atom, atom) v term) =>+           Set lit+        -> Set (Set lit)+        -> Set (Set lit)+replace cl st =+    case Set.minView st of+      Nothing -> Set.singleton cl+      Just (c, st') -> if subsumes_clause cl c+                       then Set.insert cl st'+                       else Set.insert c (replace cl st')++-- | Test for subsumption+subsumes_clause :: (IsLiteral lit, HasApply atom, IsTerm term, Match (atom, atom) v term,+                    atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+                   Set lit -> Set lit -> Bool+subsumes_clause cls1 cls2 =+    failing (const False) (const True) (subsume Map.empty cls1)+    where+      subsume env cls =+          case Set.minView cls of+            Nothing -> Success env+            Just (l1, clt) -> settryfind (\ l2 -> case (match_literals env l1 l2) of+                                                    Success env' -> subsume env' clt+                                                    Failure msgs -> Failure msgs) cls2++test03 :: Test+test03 = TestCase $ assertEqual' "Davis-Putnam example 2" expected (runSkolem (resolution2 davis_putnam_example_formula))+        where+          expected = Set.singleton (Success True)++-- | Positive (P1) resolution.+presolution :: forall fof atom term v function m.+               (IsFirstOrder fof, Unify atom v term, Match (atom, atom) v term, HasSkolem function, Monad m, Ord fof, Pretty fof,+                atom ~ AtomOf fof, term ~ TermOf atom, function ~ FunOf term, v ~ VarOf fof, v ~ SVarOf function) =>+               fof -> SkolemT m function (Set (Failing Bool))+presolution fm =+    askolemize ((.~.) (generalize fm)) >>= return . Set.map (pure_presolution . list_conj) . (simpdnf' :: fof -> Set (Set fof))++pure_presolution :: forall fof atom term v.+                    (IsFirstOrder fof, Unify atom v term, Match (atom, atom) v term, Ord fof, Pretty fof,+                     atom ~ AtomOf fof, term ~ TermOf atom, v ~ VarOf fof, v ~ TVarOf term) =>+                    fof -> Failing Bool+pure_presolution fm = presloop Set.empty (simpcnf id (specialize id (pnf fm :: fof) ::  PFormula atom) :: Set (Set (LFormula atom)))++presloop :: (JustLiteral lit, Ord lit, HasApply atom, IsTerm term,+             Match (atom, atom) v term, Unify atom v term,+             atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+            Set (Set lit) -> Set (Set lit) -> Failing Bool+presloop used unused =+    case Set.minView unused of+      Nothing -> Failure ["No proof found"]+      Just (cl, ros) ->+          -- print_string(string_of_int(length used) ^ " used; "^ string_of_int(length unused) ^ " unused.");+          -- print_newline();+          let used' = Set.insert cl used in+          let news = Set.map (presolve_clauses cl) used' in+          if Set.member Set.empty news+          then Success True+          else presloop used' (Set.fold (incorporate cl) ros news)++presolve_clauses :: (JustLiteral lit, Ord lit, HasApply atom, IsTerm term, Unify atom v term,+                     atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+                    Set lit -> Set lit -> Set lit+presolve_clauses cls1 cls2 =+    if setAll positive cls1 || setAll positive cls2+    then resolve_clauses cls1 cls2+    else Set.empty++-- | Introduce a set-of-support restriction.+resolution3 :: forall fof atom term v function m.+               (IsFirstOrder fof, Unify atom v term, Match (atom, atom) v term, HasSkolem function, Monad m, Ord fof,+                atom ~ AtomOf fof, term ~ TermOf atom, function ~ FunOf term, v ~ VarOf fof, v ~ SVarOf function) =>+               fof -> SkolemT m function (Set (Failing Bool))+resolution3 fm =+    askolemize ((.~.)(generalize fm)) >>= return . Set.map (pure_resolution3 . list_conj) . (simpdnf' :: fof -> Set (Set fof))++pure_resolution3 :: forall fof atom term v.+                    (atom ~ AtomOf fof, term ~ TermOf atom, v ~ VarOf fof, v ~ TVarOf term,+                     IsFirstOrder fof,+                     Unify atom v term,+                     Match (atom, atom) v term,+                     Ord fof, Pretty fof) => fof -> Failing Bool+pure_resolution3 fm =+    uncurry resloop2 (Set.partition (setAny positive) (simpcnf id (specialize id (pnf fm) :: PFormula atom) :: Set (Set (LFormula atom))))++instance Match (SkAtom, SkAtom) V SkTerm where+    match = match_atoms_eq+++gilmore_1 :: Test+gilmore_1 = TestCase $ assertEqual "Gilmore 1" expected (runSkolem (resolution3 fm))+    where+      expected = Set.singleton (Success True)+      fm :: Formula+      fm = exists "x" . for_all "y" . for_all "z" $+           ((f[y] .=>. g[y]) .<=>. f[x]) .&.+           ((f[y] .=>. h[y]) .<=>. g[x]) .&.+           (((f[y] .=>. g[y]) .=>. h[y]) .<=>. h[x])+           .=>. f[z] .&. g[z] .&. h[z]+      [x, y, z] = [vt "x", vt "y", vt "z"] :: [SkTerm]+      [f, g, h] = [pApp "F", pApp "G", pApp "H"]++-- The Pelletier examples again.+p1 :: Test+p1 =+    let [p, q] = [pApp (fromString "p") [], pApp (fromString "q") []] :: [Formula] in+    TestCase $ assertEqual "p1" Set.empty (runSkolem (presolution ((p .=>. q .<=>. (.~.)q .=>. (.~.)p) :: Formula)))++{-+-- -------------------------------------------------------------------------+-- The Pelletier examples again.+-- -------------------------------------------------------------------------++{- **********++let p1 = time presolution+ <<p ==> q <=> ~q ==> ~p>>;;++let p2 = time presolution+ <<~ ~p <=> p>>;;++let p3 = time presolution+ <<~(p ==> q) ==> q ==> p>>;;++let p4 = time presolution+ <<~p ==> q <=> ~q ==> p>>;;++let p5 = time presolution+ <<(p \/ q ==> p \/ r) ==> p \/ (q ==> r)>>;;++let p6 = time presolution+ <<p \/ ~p>>;;++let p7 = time presolution+ <<p \/ ~ ~ ~p>>;;++let p8 = time presolution+ <<((p ==> q) ==> p) ==> p>>;;++let p9 = time presolution+ <<(p \/ q) /\ (~p \/ q) /\ (p \/ ~q) ==> ~(~q \/ ~q)>>;;++let p10 = time presolution+ <<(q ==> r) /\ (r ==> p /\ q) /\ (p ==> q /\ r) ==> (p <=> q)>>;;++let p11 = time presolution+ <<p <=> p>>;;++let p12 = time presolution+ <<((p <=> q) <=> r) <=> (p <=> (q <=> r))>>;;++let p13 = time presolution+ <<p \/ q /\ r <=> (p \/ q) /\ (p \/ r)>>;;++let p14 = time presolution+ <<(p <=> q) <=> (q \/ ~p) /\ (~q \/ p)>>;;++let p15 = time presolution+ <<p ==> q <=> ~p \/ q>>;;++let p16 = time presolution+ <<(p ==> q) \/ (q ==> p)>>;;++let p17 = time presolution+ <<p /\ (q ==> r) ==> s <=> (~p \/ q \/ s) /\ (~p \/ ~r \/ s)>>;;++-- -------------------------------------------------------------------------+-- Monadic Predicate Logic.+-- -------------------------------------------------------------------------++let p18 = time presolution+ <<exists y. forall x. P(y) ==> P(x)>>;;++let p19 = time presolution+ <<exists x. forall y z. (P(y) ==> Q(z)) ==> P(x) ==> Q(x)>>;;++let p20 = time presolution+ <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w))+   ==> (exists x y. P(x) /\ Q(y)) ==> (exists z. R(z))>>;;++let p21 = time presolution+ <<(exists x. P ==> Q(x)) /\ (exists x. Q(x) ==> P)+   ==> (exists x. P <=> Q(x))>>;;++let p22 = time presolution+ <<(forall x. P <=> Q(x)) ==> (P <=> (forall x. Q(x)))>>;;++let p23 = time presolution+ <<(forall x. P \/ Q(x)) <=> P \/ (forall x. Q(x))>>;;++let p24 = time presolution+ <<~(exists x. U(x) /\ Q(x)) /\+   (forall x. P(x) ==> Q(x) \/ R(x)) /\+   ~(exists x. P(x) ==> (exists x. Q(x))) /\+   (forall x. Q(x) /\ R(x) ==> U(x)) ==>+   (exists x. P(x) /\ R(x))>>;;++let p25 = time presolution+ <<(exists x. P(x)) /\+   (forall x. U(x) ==> ~G(x) /\ R(x)) /\+   (forall x. P(x) ==> G(x) /\ U(x)) /\+   ((forall x. P(x) ==> Q(x)) \/ (exists x. Q(x) /\ P(x))) ==>+   (exists x. Q(x) /\ P(x))>>;;++let p26 = time presolution+ <<((exists x. P(x)) <=> (exists x. Q(x))) /\+   (forall x y. P(x) /\ Q(y) ==> (R(x) <=> U(y))) ==>+   ((forall x. P(x) ==> R(x)) <=> (forall x. Q(x) ==> U(x)))>>;;++let p27 = time presolution+ <<(exists x. P(x) /\ ~Q(x)) /\+   (forall x. P(x) ==> R(x)) /\+   (forall x. U(x) /\ V(x) ==> P(x)) /\+   (exists x. R(x) /\ ~Q(x)) ==>+   (forall x. U(x) ==> ~R(x)) ==>+   (forall x. U(x) ==> ~V(x))>>;;++let p28 = time presolution+ <<(forall x. P(x) ==> (forall x. Q(x))) /\+   ((forall x. Q(x) \/ R(x)) ==> (exists x. Q(x) /\ R(x))) /\+   ((exists x. R(x)) ==> (forall x. L(x) ==> M(x))) ==>+   (forall x. P(x) /\ L(x) ==> M(x))>>;;++let p29 = time presolution+ <<(exists x. P(x)) /\ (exists x. G(x)) ==>+   ((forall x. P(x) ==> H(x)) /\ (forall x. G(x) ==> J(x)) <=>+    (forall x y. P(x) /\ G(y) ==> H(x) /\ J(y)))>>;;++let p30 = time presolution+ <<(forall x. P(x) \/ G(x) ==> ~H(x)) /\+   (forall x. (G(x) ==> ~U(x)) ==> P(x) /\ H(x)) ==>+   (forall x. U(x))>>;;++let p31 = time presolution+ <<~(exists x. P(x) /\ (G(x) \/ H(x))) /\ (exists x. Q(x) /\ P(x)) /\+   (forall x. ~H(x) ==> J(x)) ==>+   (exists x. Q(x) /\ J(x))>>;;++let p32 = time presolution+ <<(forall x. P(x) /\ (G(x) \/ H(x)) ==> Q(x)) /\+   (forall x. Q(x) /\ H(x) ==> J(x)) /\+   (forall x. R(x) ==> H(x)) ==>+   (forall x. P(x) /\ R(x) ==> J(x))>>;;++let p33 = time presolution+ <<(forall x. P(a) /\ (P(x) ==> P(b)) ==> P(c)) <=>+   (forall x. P(a) ==> P(x) \/ P(c)) /\ (P(a) ==> P(b) ==> P(c))>>;;++let p34 = time presolution+ <<((exists x. forall y. P(x) <=> P(y)) <=>+    ((exists x. Q(x)) <=> (forall y. Q(y)))) <=>+   ((exists x. forall y. Q(x) <=> Q(y)) <=>+    ((exists x. P(x)) <=> (forall y. P(y))))>>;;++let p35 = time presolution+ <<exists x y. P(x,y) ==> (forall x y. P(x,y))>>;;++-- -------------------------------------------------------------------------+--  Full predicate logic (without Identity and Functions)+-- -------------------------------------------------------------------------++let p36 = time presolution+ <<(forall x. exists y. P(x,y)) /\+   (forall x. exists y. G(x,y)) /\+   (forall x y. P(x,y) \/ G(x,y)+   ==> (forall z. P(y,z) \/ G(y,z) ==> H(x,z)))+       ==> (forall x. exists y. H(x,y))>>;;++let p37 = time presolution+ <<(forall z.+     exists w. forall x. exists y. (P(x,z) ==> P(y,w)) /\ P(y,z) /\+     (P(y,w) ==> (exists u. Q(u,w)))) /\+   (forall x z. ~P(x,z) ==> (exists y. Q(y,z))) /\+   ((exists x y. Q(x,y)) ==> (forall x. R(x,x))) ==>+   (forall x. exists y. R(x,y))>>;;++{- ** This one seems too slow++let p38 = time presolution+ <<(forall x.+     P(a) /\ (P(x) ==> (exists y. P(y) /\ R(x,y))) ==>+     (exists z w. P(z) /\ R(x,w) /\ R(w,z))) <=>+   (forall x.+     (~P(a) \/ P(x) \/ (exists z w. P(z) /\ R(x,w) /\ R(w,z))) /\+     (~P(a) \/ ~(exists y. P(y) /\ R(x,y)) \/+     (exists z w. P(z) /\ R(x,w) /\ R(w,z))))>>;;++ ** -}++let p39 = time presolution+ <<~(exists x. forall y. P(y,x) <=> ~P(y,y))>>;;++let p40 = time presolution+ <<(exists y. forall x. P(x,y) <=> P(x,x))+  ==> ~(forall x. exists y. forall z. P(z,y) <=> ~P(z,x))>>;;++let p41 = time presolution+ <<(forall z. exists y. forall x. P(x,y) <=> P(x,z) /\ ~P(x,x))+  ==> ~(exists z. forall x. P(x,z))>>;;++{- ** Also very slow++let p42 = time presolution+ <<~(exists y. forall x. P(x,y) <=> ~(exists z. P(x,z) /\ P(z,x)))>>;;++ ** -}++{- ** and this one too..++let p43 = time presolution+ <<(forall x y. Q(x,y) <=> forall z. P(z,x) <=> P(z,y))+   ==> forall x y. Q(x,y) <=> Q(y,x)>>;;++ ** -}++let p44 = time presolution+ <<(forall x. P(x) ==> (exists y. G(y) /\ H(x,y)) /\+   (exists y. G(y) /\ ~H(x,y))) /\+   (exists x. J(x) /\ (forall y. G(y) ==> H(x,y))) ==>+   (exists x. J(x) /\ ~P(x))>>;;++{- ** and this...++let p45 = time presolution+ <<(forall x.+     P(x) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y)) ==>+       (forall y. G(y) /\ H(x,y) ==> R(y))) /\+   ~(exists y. L(y) /\ R(y)) /\+   (exists x. P(x) /\ (forall y. H(x,y) ==>+     L(y)) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y))) ==>+   (exists x. P(x) /\ ~(exists y. G(y) /\ H(x,y)))>>;;++ ** -}++{- ** and this++let p46 = time presolution+ <<(forall x. P(x) /\ (forall y. P(y) /\ H(y,x) ==> G(y)) ==> G(x)) /\+   ((exists x. P(x) /\ ~G(x)) ==>+    (exists x. P(x) /\ ~G(x) /\+               (forall y. P(y) /\ ~G(y) ==> J(x,y)))) /\+   (forall x y. P(x) /\ P(y) /\ H(x,y) ==> ~J(y,x)) ==>+   (forall x. P(x) ==> G(x))>>;;++ ** -}++-- -------------------------------------------------------------------------+-- Example from Manthey and Bry, CADE-9.+-- -------------------------------------------------------------------------++let p55 = time presolution+ <<lives(agatha) /\ lives(butler) /\ lives(charles) /\+   (killed(agatha,agatha) \/ killed(butler,agatha) \/+    killed(charles,agatha)) /\+   (forall x y. killed(x,y) ==> hates(x,y) /\ ~richer(x,y)) /\+   (forall x. hates(agatha,x) ==> ~hates(charles,x)) /\+   (hates(agatha,agatha) /\ hates(agatha,charles)) /\+   (forall x. lives(x) /\ ~richer(x,agatha) ==> hates(butler,x)) /\+   (forall x. hates(agatha,x) ==> hates(butler,x)) /\+   (forall x. ~hates(x,agatha) \/ ~hates(x,butler) \/ ~hates(x,charles))+   ==> killed(agatha,agatha) /\+       ~killed(butler,agatha) /\+       ~killed(charles,agatha)>>;;++let p57 = time presolution+ <<P(f((a),b),f(b,c)) /\+   P(f(b,c),f(a,c)) /\+   (forall (x) y z. P(x,y) /\ P(y,z) ==> P(x,z))+   ==> P(f(a,b),f(a,c))>>;;++-- -------------------------------------------------------------------------+-- See info-hol, circa 1500.+-- -------------------------------------------------------------------------++let p58 = time presolution+ <<forall P Q R. forall x. exists v. exists w. forall y. forall z.+    ((P(x) /\ Q(y)) ==> ((P(v) \/ R(w))  /\ (R(z) ==> Q(v))))>>;;++let p59 = time presolution+ <<(forall x. P(x) <=> ~P(f(x))) ==> (exists x. P(x) /\ ~P(f(x)))>>;;++let p60 = time presolution+ <<forall x. P(x,f(x)) <=>+            exists y. (forall z. P(z,y) ==> P(z,f(x))) /\ P(x,y)>>;;++-- -------------------------------------------------------------------------+-- From Gilmore's classic paper.+-- -------------------------------------------------------------------------++let gilmore_1 = time presolution+ <<exists x. forall y z.+      ((F(y) ==> G(y)) <=> F(x)) /\+      ((F(y) ==> H(y)) <=> G(x)) /\+      (((F(y) ==> G(y)) ==> H(y)) <=> H(x))+      ==> F(z) /\ G(z) /\ H(z)>>;;++{- ** This is not valid, according to Gilmore++let gilmore_2 = time presolution+ <<exists x y. forall z.+        (F(x,z) <=> F(z,y)) /\ (F(z,y) <=> F(z,z)) /\ (F(x,y) <=> F(y,x))+        ==> (F(x,y) <=> F(x,z))>>;;++ ** -}++let gilmore_3 = time presolution+ <<exists x. forall y z.+        ((F(y,z) ==> (G(y) ==> H(x))) ==> F(x,x)) /\+        ((F(z,x) ==> G(x)) ==> H(z)) /\+        F(x,y)+        ==> F(z,z)>>;;++let gilmore_4 = time presolution+ <<exists x y. forall z.+        (F(x,y) ==> F(y,z) /\ F(z,z)) /\+        (F(x,y) /\ G(x,y) ==> G(x,z) /\ G(z,z))>>;;++let gilmore_5 = time presolution+ <<(forall x. exists y. F(x,y) \/ F(y,x)) /\+   (forall x y. F(y,x) ==> F(y,y))+   ==> exists z. F(z,z)>>;;++let gilmore_6 = time presolution+ <<forall x. exists y.+        (exists u. forall v. F(u,x) ==> G(v,u) /\ G(u,x))+        ==> (exists u. forall v. F(u,y) ==> G(v,u) /\ G(u,y)) \/+            (forall u v. exists w. G(v,u) \/ H(w,y,u) ==> G(u,w))>>;;++let gilmore_7 = time presolution+ <<(forall x. K(x) ==> exists y. L(y) /\ (F(x,y) ==> G(x,y))) /\+   (exists z. K(z) /\ forall u. L(u) ==> F(z,u))+   ==> exists v w. K(v) /\ L(w) /\ G(v,w)>>;;++let gilmore_8 = time presolution+ <<exists x. forall y z.+        ((F(y,z) ==> (G(y) ==> (forall u. exists v. H(u,v,x)))) ==> F(x,x)) /\+        ((F(z,x) ==> G(x)) ==> (forall u. exists v. H(u,v,z))) /\+        F(x,y)+        ==> F(z,z)>>;;++{- ** This one still isn't easy!++let gilmore_9 = time presolution+ <<forall x. exists y. forall z.+        ((forall u. exists v. F(y,u,v) /\ G(y,u) /\ ~H(y,x))+          ==> (forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z))+             ==> (forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y))) /\+        ((forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y))+         ==> ~(forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z))+             ==> (forall u. exists v. F(y,u,v) /\ G(y,u) /\ ~H(y,x)) /\+                 (forall u. exists v. F(z,u,v) /\ G(y,u) /\ ~H(z,y)))>>;;++ ** -}++-- -------------------------------------------------------------------------+-- Example from Davis-Putnam papers where Gilmore procedure is poor.+-- -------------------------------------------------------------------------++let davis_putnam_example = time presolution+ <<exists x. exists y. forall z.+        (F(x,y) ==> (F(y,z) /\ F(z,z))) /\+        ((F(x,y) /\ G(x,y)) ==> (G(x,z) /\ G(z,z)))>>;;++*********** -}+END_INTERACTIVE;;++-- -------------------------------------------------------------------------+-- Example+-- -------------------------------------------------------------------------++START_INTERACTIVE;;+let gilmore_1 = resolution+ <<exists x. forall y z.+      ((F(y) ==> G(y)) <=> F(x)) /\+      ((F(y) ==> H(y)) <=> G(x)) /\+      (((F(y) ==> G(y)) ==> H(y)) <=> H(x))+      ==> F(z) /\ G(z) /\ H(z)>>;;++-- -------------------------------------------------------------------------+-- Pelletiers yet again.+-- -------------------------------------------------------------------------++{- ************++let p1 = time resolution+ <<p ==> q <=> ~q ==> ~p>>;;++let p2 = time resolution+ <<~ ~p <=> p>>;;++let p3 = time resolution+ <<~(p ==> q) ==> q ==> p>>;;++let p4 = time resolution+ <<~p ==> q <=> ~q ==> p>>;;++let p5 = time resolution+ <<(p \/ q ==> p \/ r) ==> p \/ (q ==> r)>>;;++let p6 = time resolution+ <<p \/ ~p>>;;++let p7 = time resolution+ <<p \/ ~ ~ ~p>>;;++let p8 = time resolution+ <<((p ==> q) ==> p) ==> p>>;;++let p9 = time resolution+ <<(p \/ q) /\ (~p \/ q) /\ (p \/ ~q) ==> ~(~q \/ ~q)>>;;++let p10 = time resolution+ <<(q ==> r) /\ (r ==> p /\ q) /\ (p ==> q /\ r) ==> (p <=> q)>>;;++let p11 = time resolution+ <<p <=> p>>;;++let p12 = time resolution+ <<((p <=> q) <=> r) <=> (p <=> (q <=> r))>>;;++let p13 = time resolution+ <<p \/ q /\ r <=> (p \/ q) /\ (p \/ r)>>;;++let p14 = time resolution+ <<(p <=> q) <=> (q \/ ~p) /\ (~q \/ p)>>;;++let p15 = time resolution+ <<p ==> q <=> ~p \/ q>>;;++let p16 = time resolution+ <<(p ==> q) \/ (q ==> p)>>;;++let p17 = time resolution+ <<p /\ (q ==> r) ==> s <=> (~p \/ q \/ s) /\ (~p \/ ~r \/ s)>>;;++(* ------------------------------------------------------------------------- *)+(* Monadic Predicate Logic.                                                  *)+(* ------------------------------------------------------------------------- *)++let p18 = time resolution+ <<exists y. forall x. P(y) ==> P(x)>>;;++let p19 = time resolution+ <<exists x. forall y z. (P(y) ==> Q(z)) ==> P(x) ==> Q(x)>>;;++let p20 = time resolution+ <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w)) ==>+   (exists x y. P(x) /\ Q(y)) ==>+   (exists z. R(z))>>;;++let p21 = time resolution+ <<(exists x. P ==> Q(x)) /\ (exists x. Q(x) ==> P) ==> (exists x. P <=> Q(x))>>;;++let p22 = time resolution+ <<(forall x. P <=> Q(x)) ==> (P <=> (forall x. Q(x)))>>;;++let p23 = time resolution+ <<(forall x. P \/ Q(x)) <=> P \/ (forall x. Q(x))>>;;++let p24 = time resolution+ <<~(exists x. U(x) /\ Q(x)) /\+   (forall x. P(x) ==> Q(x) \/ R(x)) /\+   ~(exists x. P(x) ==> (exists x. Q(x))) /\+   (forall x. Q(x) /\ R(x) ==> U(x)) ==>+   (exists x. P(x) /\ R(x))>>;;++let p25 = time resolution+ <<(exists x. P(x)) /\+   (forall x. U(x) ==> ~G(x) /\ R(x)) /\+   (forall x. P(x) ==> G(x) /\ U(x)) /\+   ((forall x. P(x) ==> Q(x)) \/ (exists x. Q(x) /\ P(x))) ==>+   (exists x. Q(x) /\ P(x))>>;;++let p26 = time resolution+ <<((exists x. P(x)) <=> (exists x. Q(x))) /\+   (forall x y. P(x) /\ Q(y) ==> (R(x) <=> U(y))) ==>+   ((forall x. P(x) ==> R(x)) <=> (forall x. Q(x) ==> U(x)))>>;;++let p27 = time resolution+ <<(exists x. P(x) /\ ~Q(x)) /\+   (forall x. P(x) ==> R(x)) /\+   (forall x. U(x) /\ V(x) ==> P(x)) /\+   (exists x. R(x) /\ ~Q(x)) ==>+   (forall x. U(x) ==> ~R(x)) ==>+   (forall x. U(x) ==> ~V(x))>>;;++let p28 = time resolution+ <<(forall x. P(x) ==> (forall x. Q(x))) /\+   ((forall x. Q(x) \/ R(x)) ==> (exists x. Q(x) /\ R(x))) /\+   ((exists x. R(x)) ==> (forall x. L(x) ==> M(x))) ==>+   (forall x. P(x) /\ L(x) ==> M(x))>>;;++let p29 = time resolution+ <<(exists x. P(x)) /\ (exists x. G(x)) ==>+   ((forall x. P(x) ==> H(x)) /\ (forall x. G(x) ==> J(x)) <=>+    (forall x y. P(x) /\ G(y) ==> H(x) /\ J(y)))>>;;++let p30 = time resolution+ <<(forall x. P(x) \/ G(x) ==> ~H(x)) /\ (forall x. (G(x) ==> ~U(x)) ==>+     P(x) /\ H(x)) ==>+   (forall x. U(x))>>;;++let p31 = time resolution+ <<~(exists x. P(x) /\ (G(x) \/ H(x))) /\ (exists x. Q(x) /\ P(x)) /\+   (forall x. ~H(x) ==> J(x)) ==>+   (exists x. Q(x) /\ J(x))>>;;++let p32 = time resolution+ <<(forall x. P(x) /\ (G(x) \/ H(x)) ==> Q(x)) /\+   (forall x. Q(x) /\ H(x) ==> J(x)) /\+   (forall x. R(x) ==> H(x)) ==>+   (forall x. P(x) /\ R(x) ==> J(x))>>;;++let p33 = time resolution+ <<(forall x. P(a) /\ (P(x) ==> P(b)) ==> P(c)) <=>+   (forall x. P(a) ==> P(x) \/ P(c)) /\ (P(a) ==> P(b) ==> P(c))>>;;++let p34 = time resolution+ <<((exists x. forall y. P(x) <=> P(y)) <=>+   ((exists x. Q(x)) <=> (forall y. Q(y)))) <=>+   ((exists x. forall y. Q(x) <=> Q(y)) <=>+  ((exists x. P(x)) <=> (forall y. P(y))))>>;;++let p35 = time resolution+ <<exists x y. P(x,y) ==> (forall x y. P(x,y))>>;;++(* ------------------------------------------------------------------------- *)+(*  Full predicate logic (without Identity and Functions)                    *)+(* ------------------------------------------------------------------------- *)++let p36 = time resolution+ <<(forall x. exists y. P(x,y)) /\+   (forall x. exists y. G(x,y)) /\+   (forall x y. P(x,y) \/ G(x,y)+   ==> (forall z. P(y,z) \/ G(y,z) ==> H(x,z)))+       ==> (forall x. exists y. H(x,y))>>;;++let p37 = time resolution+ <<(forall z.+     exists w. forall x. exists y. (P(x,z) ==> P(y,w)) /\ P(y,z) /\+     (P(y,w) ==> (exists u. Q(u,w)))) /\+   (forall x z. ~P(x,z) ==> (exists y. Q(y,z))) /\+   ((exists x y. Q(x,y)) ==> (forall x. R(x,x))) ==>+   (forall x. exists y. R(x,y))>>;;++(*** This one seems too slow++let p38 = time resolution+ <<(forall x.+     P(a) /\ (P(x) ==> (exists y. P(y) /\ R(x,y))) ==>+     (exists z w. P(z) /\ R(x,w) /\ R(w,z))) <=>+   (forall x.+     (~P(a) \/ P(x) \/ (exists z w. P(z) /\ R(x,w) /\ R(w,z))) /\+     (~P(a) \/ ~(exists y. P(y) /\ R(x,y)) \/+     (exists z w. P(z) /\ R(x,w) /\ R(w,z))))>>;;++ ***)++let p39 = time resolution+ <<~(exists x. forall y. P(y,x) <=> ~P(y,y))>>;;++let p40 = time resolution+ <<(exists y. forall x. P(x,y) <=> P(x,x))+  ==> ~(forall x. exists y. forall z. P(z,y) <=> ~P(z,x))>>;;++let p41 = time resolution+ <<(forall z. exists y. forall x. P(x,y) <=> P(x,z) /\ ~P(x,x))+  ==> ~(exists z. forall x. P(x,z))>>;;++(*** Also very slow++let p42 = time resolution+ <<~(exists y. forall x. P(x,y) <=> ~(exists z. P(x,z) /\ P(z,x)))>>;;++ ***)++(*** and this one too..++let p43 = time resolution+ <<(forall x y. Q(x,y) <=> forall z. P(z,x) <=> P(z,y))+   ==> forall x y. Q(x,y) <=> Q(y,x)>>;;++ ***)++let p44 = time resolution+ <<(forall x. P(x) ==> (exists y. G(y) /\ H(x,y)) /\+   (exists y. G(y) /\ ~H(x,y))) /\+   (exists x. J(x) /\ (forall y. G(y) ==> H(x,y))) ==>+   (exists x. J(x) /\ ~P(x))>>;;++(*** and this...++let p45 = time resolution+ <<(forall x.+     P(x) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y)) ==>+       (forall y. G(y) /\ H(x,y) ==> R(y))) /\+   ~(exists y. L(y) /\ R(y)) /\+   (exists x. P(x) /\ (forall y. H(x,y) ==>+     L(y)) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y))) ==>+   (exists x. P(x) /\ ~(exists y. G(y) /\ H(x,y)))>>;;++ ***)++(*** and this++let p46 = time resolution+ <<(forall x. P(x) /\ (forall y. P(y) /\ H(y,x) ==> G(y)) ==> G(x)) /\+   ((exists x. P(x) /\ ~G(x)) ==>+    (exists x. P(x) /\ ~G(x) /\+               (forall y. P(y) /\ ~G(y) ==> J(x,y)))) /\+   (forall x y. P(x) /\ P(y) /\ H(x,y) ==> ~J(y,x)) ==>+   (forall x. P(x) ==> G(x))>>;;++ ***)++(* ------------------------------------------------------------------------- *)+(* Example from Manthey and Bry, CADE-9.                                     *)+(* ------------------------------------------------------------------------- *)++let p55 = time resolution+ <<lives(agatha) /\ lives(butler) /\ lives(charles) /\+   (killed(agatha,agatha) \/ killed(butler,agatha) \/+    killed(charles,agatha)) /\+   (forall x y. killed(x,y) ==> hates(x,y) /\ ~richer(x,y)) /\+   (forall x. hates(agatha,x) ==> ~hates(charles,x)) /\+   (hates(agatha,agatha) /\ hates(agatha,charles)) /\+   (forall x. lives(x) /\ ~richer(x,agatha) ==> hates(butler,x)) /\+   (forall x. hates(agatha,x) ==> hates(butler,x)) /\+   (forall x. ~hates(x,agatha) \/ ~hates(x,butler) \/ ~hates(x,charles))+   ==> killed(agatha,agatha) /\+       ~killed(butler,agatha) /\+       ~killed(charles,agatha)>>;;++let p57 = time resolution+ <<P(f((a),b),f(b,c)) /\+   P(f(b,c),f(a,c)) /\+   (forall (x) y z. P(x,y) /\ P(y,z) ==> P(x,z))+   ==> P(f(a,b),f(a,c))>>;;++(* ------------------------------------------------------------------------- *)+(* See info-hol, circa 1500.                                                 *)+(* ------------------------------------------------------------------------- *)++let p58 = time resolution+ <<forall P Q R. forall x. exists v. exists w. forall y. forall z.+    ((P(x) /\ Q(y)) ==> ((P(v) \/ R(w))  /\ (R(z) ==> Q(v))))>>;;++let p59 = time resolution+ <<(forall x. P(x) <=> ~P(f(x))) ==> (exists x. P(x) /\ ~P(f(x)))>>;;++let p60 = time resolution+ <<forall x. P(x,f(x)) <=>+            exists y. (forall z. P(z,y) ==> P(z,f(x))) /\ P(x,y)>>;;++(* ------------------------------------------------------------------------- *)+(* From Gilmore's classic paper.                                             *)+(* ------------------------------------------------------------------------- *)++let gilmore_1 = time resolution+ <<exists x. forall y z.+      ((F(y) ==> G(y)) <=> F(x)) /\+      ((F(y) ==> H(y)) <=> G(x)) /\+      (((F(y) ==> G(y)) ==> H(y)) <=> H(x))+      ==> F(z) /\ G(z) /\ H(z)>>;;++(*** This is not valid, according to Gilmore++let gilmore_2 = time resolution+ <<exists x y. forall z.+        (F(x,z) <=> F(z,y)) /\ (F(z,y) <=> F(z,z)) /\ (F(x,y) <=> F(y,x))+        ==> (F(x,y) <=> F(x,z))>>;;++ ***)++let gilmore_3 = time resolution+ <<exists x. forall y z.+        ((F(y,z) ==> (G(y) ==> H(x))) ==> F(x,x)) /\+        ((F(z,x) ==> G(x)) ==> H(z)) /\+        F(x,y)+        ==> F(z,z)>>;;++let gilmore_4 = time resolution+ <<exists x y. forall z.+        (F(x,y) ==> F(y,z) /\ F(z,z)) /\+        (F(x,y) /\ G(x,y) ==> G(x,z) /\ G(z,z))>>;;++let gilmore_5 = time resolution+ <<(forall x. exists y. F(x,y) \/ F(y,x)) /\+   (forall x y. F(y,x) ==> F(y,y))+   ==> exists z. F(z,z)>>;;++let gilmore_6 = time resolution+ <<forall x. exists y.+        (exists u. forall v. F(u,x) ==> G(v,u) /\ G(u,x))+        ==> (exists u. forall v. F(u,y) ==> G(v,u) /\ G(u,y)) \/+            (forall u v. exists w. G(v,u) \/ H(w,y,u) ==> G(u,w))>>;;++let gilmore_7 = time resolution+ <<(forall x. K(x) ==> exists y. L(y) /\ (F(x,y) ==> G(x,y))) /\+   (exists z. K(z) /\ forall u. L(u) ==> F(z,u))+   ==> exists v w. K(v) /\ L(w) /\ G(v,w)>>;;++let gilmore_8 = time resolution+ <<exists x. forall y z.+        ((F(y,z) ==> (G(y) ==> (forall u. exists v. H(u,v,x)))) ==> F(x,x)) /\+        ((F(z,x) ==> G(x)) ==> (forall u. exists v. H(u,v,z))) /\+        F(x,y)+        ==> F(z,z)>>;;++(*** This one still isn't easy!++let gilmore_9 = time resolution+ <<forall x. exists y. forall z.+        ((forall u. exists v. F(y,u,v) /\ G(y,u) /\ ~H(y,x))+          ==> (forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z))+             ==> (forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y))) /\+        ((forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y))+         ==> ~(forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z))+             ==> (forall u. exists v. F(y,u,v) /\ G(y,u) /\ ~H(y,x)) /\+                 (forall u. exists v. F(z,u,v) /\ G(y,u) /\ ~H(z,y)))>>;;++ ***)++(* ------------------------------------------------------------------------- *)+(* Example from Davis-Putnam papers where Gilmore procedure is poor.         *)+(* ------------------------------------------------------------------------- *)++let davis_putnam_example = time resolution+ <<exists x. exists y. forall z.+        (F(x,y) ==> (F(y,z) /\ F(z,z))) /\+        ((F(x,y) /\ G(x,y)) ==> (G(x,z) /\ G(z,z)))>>;;+-}+-}++-- | The (in)famous Los problem.+los :: Test+los =+    let [x, y, z] = List.map (vt :: V -> SkTerm) ["x", "y", "z"]+        [p, q] = List.map pApp ["P", "Q"] :: [[SkTerm] -> Formula]+        fm = (for_all "x" $ for_all "y" $ for_all "z" $ p[x,y] .=>. p[y,z] .=>. p[x,z]) .&.+             (for_all "x" $ for_all "y" $ for_all "z" $ q[x,y] .=>. q[y,z] .=>. q[x,z]) .&.+             (for_all "x" $ for_all "y" $ q[x,y] .=>. q[y,x]) .&.+             (for_all "x" $ for_all "y" $ p[x,y] .|. q[x,y])+             .=>. (for_all "x" $ for_all "y" $ p[x,y]) .|. (for_all "x" $ for_all "y" $ q[x,y]) :: Formula+        result = {-time-} runSkolem (presolution fm)+        expected = Set.singleton (Success True) in+    TestCase $ assertEqual "los (p. 198)" expected result++testResolution :: Test+testResolution = TestLabel "Resolution" (TestList [test01, test02, test03, gilmore_1, p1, los])
+ src/Data/Logic/ATP/Skolem.hs view
@@ -0,0 +1,456 @@+-- | Prenex and Skolem normal forms.+--+-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Logic.ATP.Skolem+    (+    -- * Class of Skolem functions+      HasSkolem(SVarOf, toSkolem, foldSkolem, variantSkolem)+    , showSkolem+    , prettySkolem+    -- * Skolem monad+    , SkolemM+    , runSkolem+    , SkolemT+    , runSkolemT+    -- * Skolemization procedure+    , simplify+    , nnf+    , pnf+    , skolems+    , askolemize+    , skolemize+    , specialize+    -- * Normalization+    , simpdnf'+    , simpcnf'+    -- * Instances+    , Function(Fn, Skolem)+    , Formula, SkTerm, SkAtom+    -- * Tests+    , testSkolem+    ) where++import Control.Monad.Identity (Identity, runIdentity)+import Control.Monad.State (runStateT, StateT, get, modify)+import Data.Data (Data)+import Data.List as List (map)+import Data.Logic.ATP.Apply (functions, HasApply(TermOf, PredOf), pApp, Predicate)+import Data.Logic.ATP.Equate (FOL)+import Data.Logic.ATP.FOL (fv, IsFirstOrder, subst)+import Data.Logic.ATP.Formulas (IsFormula(AtomOf), false, true, atomic)+import Data.Logic.ATP.Lib (setAny, distrib)+import Data.Logic.ATP.Lit ((.~.), negate)+import Data.Logic.ATP.Pretty (brackets, Doc, Pretty(pPrint), prettyShow, text)+import Data.Logic.ATP.Prop ((.&.), (.|.), (.=>.), (.<=>.), BinOp((:&:), (:|:), (:=>:), (:<=>:)),+                            convertToPropositional, foldPropositional', JustPropositional, PFormula, psimplify1, trivial)+import Data.Logic.ATP.Quantified (exists, for_all, IsQuantified(VarOf, foldQuantified),+                                  QFormula, quant, Quant((:?:), (:!:)))+import Data.Logic.ATP.Term (fApp, IsFunction, IsTerm(TVarOf, FunOf), IsVariable, Term, V, variant, vt)+import Data.Map.Strict as Map (singleton)+import Data.Monoid ((<>))+import Data.Set as Set (empty, filter, insert, isProperSubsetOf, map, member, notMember, Set, singleton, toAscList, union)+import Data.String (IsString(fromString))+import Data.Typeable (Typeable)+import Prelude hiding (negate)+import Test.HUnit++-- | Class of functions that include embedded Skolem functions+--+-- A Skolem function is created to eliminate an an existentially+-- quantified variable.  The idea is that if we have a predicate+-- @P[x,y,z]@, and @z@ is existentially quantified, then @P@ is only+-- satisfiable if there *exists* at least one @z@ that causes @P@ to+-- be true.  Therefore, we envision a function @sKz[x,y]@ whose value+-- is one of the z's that cause @P@ to be satisfied (if there are any;+-- if the formula is satisfiable there must be.)  Because we are+-- trying to determine if there is a satisfying triple @x, y, z@, the+-- Skolem function @sKz@ will have to be a function of @x@ and @y@, so+-- we make these parameters.  Now, if @P[x,y,z]@ is satisfiable, there+-- will be a function sKz which can be substituted in such that+-- @P[x,y,sKz[x,y]]@ is also satisfiable.  Thus, using this mechanism+-- we can eliminate all the formula's existential quantifiers and some+-- of its variables.+class (IsFunction function, IsVariable (SVarOf function)) => HasSkolem function where+    type SVarOf function+    toSkolem :: SVarOf function -> Int -> function+    -- ^ Create a skolem function with a variant number that differs+    -- from all the members of the set.+    foldSkolem :: (function -> r) -> (SVarOf function -> Int -> r) -> function -> r+    variantSkolem :: function -> Set function -> function+    -- ^ Return a function based on f but different from any set+    -- element.  The result may be f itself if f is not a member of+    -- the set.++-- fromSkolem :: HasSkolem function v => function -> Maybe v+-- fromSkolem = foldSkolem (const Nothing) Just++showSkolem :: (HasSkolem function, IsVariable (SVarOf function)) => function -> String+showSkolem = foldSkolem (show . prettyShow) (\v n -> "(toSkolem " ++ show v ++ " " ++ show n ++ ")")++prettySkolem :: HasSkolem function => (function -> Doc) -> function -> Doc+prettySkolem prettyFunction =+    foldSkolem prettyFunction (\v n -> text "sK" <> brackets (pPrint v <> if n == 1 then mempty else (text "." <> pPrint (show n))))++-- | State monad for generating Skolem functions and constants.+type SkolemT m function = StateT (SkolemState function) m+type SkolemM function = StateT (SkolemState function) Identity++-- | The state associated with the Skolem monad.+data SkolemState function+    = SkolemState+      { skolemSet :: Set function+        -- ^ The set of allocated skolem functions+      , univQuant :: [String]+        -- ^ The variables which are universally quantified in the+        -- current scope, in the order they were encountered.  During+        -- Skolemization these are the parameters passed to the Skolem+        -- function.+      }++-- | Run a computation in a stacked invocation of the Skolem monad.+runSkolemT :: (Monad m, IsFunction function) => SkolemT m function a -> m a+runSkolemT action = (runStateT action) newSkolemState >>= return . fst+    where+      newSkolemState :: IsFunction function => SkolemState function+      newSkolemState+          = SkolemState+            { skolemSet = mempty+            , univQuant = []+            }++-- | Run a pure computation in the Skolem monad.+runSkolem :: IsFunction function => SkolemT Identity function a -> a+runSkolem = runIdentity . runSkolemT++-- -------------------------------------------------------------------------+-- Simplification, normal forms, and the skolemization procedure+-- -------------------------------------------------------------------------++-- | Routine simplification. Like "psimplify" but with quantifier clauses.+simplify :: IsFirstOrder formula => formula -> formula+simplify fm =+    foldQuantified qu co ne (\_ -> fm) (\_ -> fm) fm+    where+      qu (:!:) x p = simplify1 (for_all x (simplify p))+      qu (:?:) x p = simplify1 (exists x (simplify p))+      ne p = simplify1 ((.~.) (simplify p))+      co p (:&:) q = simplify1 (simplify p .&. simplify q)+      co p (:|:) q = simplify1 (simplify p .|. simplify q)+      co p (:=>:) q = simplify1 (simplify p .=>. simplify q)+      co p (:<=>:) q = simplify1 (simplify p .<=>. simplify q)++simplify1 :: IsFirstOrder formula => formula -> formula+simplify1 fm =+    foldQuantified qu (\_ _ _ -> psimplify1 fm) (\_ -> psimplify1 fm) (\_ -> psimplify1 fm) (\_ -> psimplify1 fm) fm+    where+      qu _ x p = if member x (fv p) then fm else p++-- Example.+test01 :: Test+test01 = TestCase $ assertEqual ("simplify (p. 140) " ++ prettyShow fm) expected input+    where input = prettyShow (simplify fm)+          expected = prettyShow ((for_all "x" (pApp "P" [vt "x"])) .=>. (pApp "Q" []) :: Formula)+          fm :: Formula+          fm = (for_all "x" (for_all "y" (pApp "P" [vt "x"] .|. (pApp "P" [vt "y"] .&. false)))) .=>. exists "z" (pApp "Q" [])++-- | Negation normal form for first order formulas+nnf :: IsFirstOrder formula => formula -> formula+nnf = nnf1 . simplify++nnf1 :: IsQuantified formula => formula -> formula+nnf1 fm =+    foldQuantified qu co ne (\_ -> fm) (\_ -> fm) fm+    where+      qu (:!:) x p = quant (:!:) x (nnf1 p)+      qu (:?:) x p = quant (:?:) x (nnf1 p)+      ne p = foldQuantified quNot coNot neNot (\_ -> fm) (\_ -> fm) p+      co p (:&:) q = nnf1 p .&. nnf1 q+      co p (:|:) q = nnf1 p .|. nnf1 q+      co p (:=>:) q = nnf1 ((.~.) p) .|. nnf1 q+      co p (:<=>:) q = (nnf1 p .&. nnf1 q) .|. (nnf1 ((.~.) p) .&. nnf1 ((.~.) q))+      quNot (:!:) x p = quant (:?:) x (nnf1 ((.~.) p))+      quNot (:?:) x p = quant (:!:) x (nnf1 ((.~.) p))+      neNot p = nnf1 p+      coNot p (:&:) q = nnf1 ((.~.) p) .|. nnf1 ((.~.) q)+      coNot p (:|:) q = nnf1 ((.~.) p) .&. nnf1 ((.~.) q)+      coNot p (:=>:) q = nnf1 p .&. nnf1 ((.~.) q)+      coNot p (:<=>:) q = (nnf1 p .&. nnf1 ((.~.) q)) .|. (nnf1 ((.~.) p) .&. nnf1 q)++-- Example of NNF function in action.+test02 :: Test+test02 = TestCase $ assertEqual "nnf (p. 140)" expected input+    where p = "P"+          q = "Q"+          input = nnf fm+          expected = exists "x" ((.~.)(pApp p [vt "x"])) .|.+                     ((exists "y" (pApp q [vt "y"]) .&. exists "z" ((pApp p [vt "z"]) .&. (pApp q [vt "z"]))) .|.+                      (for_all "y" ((.~.)(pApp q [vt "y"])) .&.+                       for_all "z" (((.~.)(pApp p [vt "z"])) .|. ((.~.)(pApp q [vt "z"])))) :: Formula)+          fm :: Formula+          fm = (for_all "x" (pApp p [vt "x"])) .=>. ((exists "y" (pApp q [vt "y"])) .<=>. exists "z" (pApp p [vt "z"] .&. pApp q [vt "z"]))++-- | Prenex normal form.+pnf :: IsFirstOrder formula => formula -> formula+pnf = prenex . nnf . simplify++prenex :: IsFirstOrder formula => formula -> formula+prenex fm =+    foldQuantified qu co (\ _ -> fm) (\ _ -> fm) (\ _ -> fm) fm+    where+      qu op x p = quant op x (prenex p)+      co l (:&:) r = pullquants (prenex l .&. prenex r)+      co l (:|:) r = pullquants (prenex l .|. prenex r)+      co _ _ _ = fm++pullquants :: IsFirstOrder formula => formula -> formula+pullquants fm =+    foldQuantified (\_ _ _ -> fm) pullQuantsCombine (\_ -> fm) (\_ -> fm) (\_ -> fm) fm+    where+      pullQuantsCombine l op r =+          case (getQuant l, op, getQuant r) of+            (Just ((:!:), vl, l'), (:&:), Just ((:!:), vr, r')) -> pullq (True,  True)  fm for_all (.&.) vl vr l' r'+            (Just ((:?:), vl, l'), (:|:), Just ((:?:), vr, r')) -> pullq (True,  True)  fm exists  (.|.) vl vr l' r'+            (Just ((:!:), vl, l'), (:&:), _)                    -> pullq (True,  False) fm for_all (.&.) vl vl l' r+            (_,                    (:&:), Just ((:!:), vr, r')) -> pullq (False, True)  fm for_all (.&.) vr vr l  r'+            (Just ((:!:), vl, l'), (:|:), _)                    -> pullq (True,  False) fm for_all (.|.) vl vl l' r+            (_,                    (:|:), Just ((:!:), vr, r')) -> pullq (False, True)  fm for_all (.|.) vr vr l  r'+            (Just ((:?:), vl, l'), (:&:), _)                    -> pullq (True,  False) fm exists  (.&.) vl vl l' r+            (_,                    (:&:), Just ((:?:), vr, r')) -> pullq (False, True)  fm exists  (.&.) vr vr l  r'+            (Just ((:?:), vl, l'), (:|:), _)                    -> pullq (True,  False) fm exists  (.|.) vl vl l' r+            (_,                    (:|:), Just ((:?:), vr, r')) -> pullq (False, True)  fm exists  (.|.) vr vr l  r'+            _                                                   -> fm+      getQuant = foldQuantified (\ op v f -> Just (op, v, f)) (\ _ _ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing)++pullq :: (IsFirstOrder formula, v ~ VarOf formula) =>+         (Bool, Bool)+      -> formula+      -> (v -> formula -> formula)+      -> (formula -> formula -> formula)+      -> v+      -> v+      -> formula+      -> formula+      -> formula+pullq (l,r) fm qu op x y p q =+  let z = variant x (fv fm) in+  let p' = if l then subst (Map.singleton x (vt z)) p else p+      q' = if r then subst (Map.singleton y (vt z)) q else q in+  qu z (pullquants (op p' q'))++-- Example.++test03 :: Test+test03 = TestCase $ assertEqual "pnf (p. 144)" (prettyShow expected) (prettyShow input)+    where p = "P"+          q = "Q"+          r = "R"+          input = pnf fm+          expected = exists "x" (for_all "z"+                                 ((((.~.)(pApp p [vt "x"])) .&. ((.~.)(pApp r [vt "y"]))) .|.+                                  ((pApp q [vt "x"]) .|.+                                   (((.~.)(pApp p [vt "z"])) .|.+                                    ((.~.)(pApp q [vt "z"])))))) :: Formula+          fm :: Formula+          fm = (for_all "x" (pApp p [vt "x"]) .|. (pApp r [vt "y"])) .=>.+               exists "y" (exists "z" ((pApp q [vt "y"]) .|. ((.~.)(exists "z" (pApp p [vt "z"] .&. pApp q [vt "z"])))))++-- | Extract the skolem functions from a formula.+skolems :: (IsFormula formula, HasSkolem function, HasApply atom, Ord function,+            atom ~ AtomOf formula,+            term ~ TermOf atom,+            function ~ FunOf term {-,+            v ~ TVarOf term,+            v ~ SVarOf function-}) => formula -> Set function+skolems = Set.filter (foldSkolem (const False) (\_ _ -> True)) . Set.map fst . functions++-- | Core Skolemization function.+--+-- Skolemize the formula by removing the existential quantifiers and+-- replacing the variables they quantify with skolem functions (and+-- constants, which are functions of zero variables.)  The Skolem+-- functions are new functions (obtained from the SkolemT monad) which+-- are applied to the list of variables which are universally+-- quantified in the context where the existential quantifier+-- appeared.+skolem :: (IsFirstOrder formula, HasSkolem function, Monad m,+           atom ~ AtomOf formula,+           term ~ TermOf atom,+           function ~ FunOf term,+           VarOf formula ~ SVarOf function {-,+           predicate ~ PredOf atom-}) =>+          formula -> SkolemT m function formula+skolem fm =+    foldQuantified qu co ne tf (return . atomic) fm+    where+      qu (:?:) y p =+          do sk <- newSkolem y+             let xs = fv fm+             let fx = fApp sk (List.map vt (Set.toAscList xs))+             skolem (subst (Map.singleton y fx) p)+      qu (:!:) x p = skolem p >>= return . for_all x+      co l (:&:) r = skolem2 (.&.) l r+      co l (:|:) r = skolem2 (.|.) l r+      co _ _ _ = return fm+      ne _ = return fm+      tf True = return true+      tf False = return false++newSkolem :: (Monad m, HasSkolem function, v ~ SVarOf function) => v -> SkolemT m function function+newSkolem v = do+  f <- variantSkolem (toSkolem v 1) <$> skolemSet <$> get+  modify (\s -> s {skolemSet = Set.insert f (skolemSet s)})+  return f++skolem2 :: (IsFirstOrder formula, HasSkolem function, Monad m,+            atom ~ AtomOf formula,+            term ~ TermOf atom,+            function ~ FunOf term,+            VarOf formula ~ SVarOf function) =>+           (formula -> formula -> formula) -> formula -> formula -> SkolemT m function formula+skolem2 cons p q =+    skolem p >>= \ p' ->+    skolem q >>= \ q' ->+    return (cons p' q')++-- | Overall Skolemization function.+askolemize :: (IsFirstOrder formula, HasSkolem function, Monad m,+               atom ~ AtomOf formula,+               term ~ TermOf atom,+               function ~ FunOf term,+               VarOf formula ~ SVarOf function) =>+              formula -> SkolemT m function formula+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.  For this reason we can safely convert to any+-- instance of IsPropositional.+specialize :: (IsQuantified fof, JustPropositional pf) => (AtomOf fof -> AtomOf pf) -> fof -> pf+specialize ca fm =+    convertToPropositional (error "specialize failure") ca (specialize' fm)+    where+      specialize' p = foldQuantified qu (\_ _ _ -> p) (\_ -> p) (\_ -> p) (\_ -> p) p+      qu (:!:) _ p = specialize' p+      qu _ _ _ = fm++-- | Skolemize and then specialize.  Because we know all quantifiers+-- are gone we can convert to any instance of IsPropositional.+skolemize :: (IsFirstOrder formula, JustPropositional pf, HasSkolem function, Monad m,+              atom ~ AtomOf formula,+              term ~ TermOf atom,+              function ~ FunOf term,+              VarOf formula ~ SVarOf function) =>+             (AtomOf formula -> AtomOf pf) -> formula -> StateT (SkolemState function) m pf+skolemize ca fm = (specialize ca . pnf) <$> askolemize fm++-- | A function type that is an instance of HasSkolem+data Function+    = Fn String+    | Skolem V Int+    deriving (Eq, Ord, Data, Typeable, Read)++instance IsFunction Function++instance IsString Function where+    fromString = Fn++instance Show Function where+    show = showSkolem++instance Pretty Function where+    pPrint = prettySkolem (\(Fn s) -> text s)++instance HasSkolem Function where+    type SVarOf Function = V+    toSkolem = Skolem+    foldSkolem _ sk (Skolem v n) = sk v n+    foldSkolem other _ f = other f+    variantSkolem f fns | Set.notMember f fns = f+    variantSkolem (Fn s) fns = variantSkolem (fromString (s ++ "'")) fns+    variantSkolem (Skolem v n) fns = variantSkolem (Skolem v (succ n)) fns++-- | A first order logic formula type with an equality predicate and skolem functions.+type Formula = QFormula V SkAtom+type SkAtom = FOL Predicate SkTerm+type SkTerm = Term Function V++instance IsFirstOrder Formula++test04 :: Test+test04 = TestCase $ assertEqual "skolemize 1 (p. 150)" expected input+    where input = runSkolem (skolemize id fm) :: PFormula SkAtom+          fm :: Formula+          fm = exists "y" (pApp ("<") [vt "x", vt "y"] .=>.+                           for_all "u" (exists "v" (pApp ("<") [fApp "*" [vt "x", vt "u"],  fApp "*" [vt "y", vt "v"]])))+          expected = ((.~.)(pApp ("<") [vt "x",fApp (Skolem "y" 1) [vt "x"]])) .|.+                     (pApp ("<") [fApp "*" [vt "x",vt "u"],fApp "*" [fApp (Skolem "y" 1) [vt "x"],fApp (Skolem "v" 1) [vt "u",vt "x"]]])++test05 :: Test+test05 = TestCase $ assertEqual "skolemize 2 (p. 150)" expected input+    where p = "P"+          q = "Q"+          input = runSkolem (skolemize id fm) :: PFormula SkAtom+          fm :: Formula+          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 "y" 1) []]) .|.+                      (((.~.)(pApp p [vt "z"])) .|.+                       ((.~.)(pApp q [vt "z"]))))++-- | Versions of the normal form functions that leave quantifiers in place.+simpdnf' :: (IsFirstOrder fof, Ord fof,+             atom ~ AtomOf fof, term ~ TermOf atom, function ~ FunOf term,+             v ~ VarOf fof, v ~ TVarOf term) =>+            fof -> Set (Set fof)+simpdnf' fm =+    foldQuantified (\_ _ _ -> go) (\_ _ _ -> go) (\_ -> go) tf (\_ -> go) fm+    where+      tf False = Set.empty+      tf True = Set.singleton Set.empty+      go = let djs = Set.filter (not . trivial) (purednf' (nnf fm)) in+           Set.filter (\d -> not (setAny (\d' -> Set.isProperSubsetOf d' d) djs)) djs++purednf' :: (IsQuantified fof, Ord fof) => fof -> Set (Set fof)+purednf' fm =+    {-t4 $-}+    foldPropositional' ho co (\_ -> lf fm) (\_ -> lf fm) (\_ -> lf fm) ({-t3-} fm)+    where+      lf = Set.singleton . Set.singleton+      ho _ = lf fm+      co p (:&:) q = distrib (purednf' p) (purednf' q)+      co p (:|:) q = union (purednf' p) (purednf' q)+      co _ _ _ = lf fm+      -- t3 x = trace ("purednf' (" ++ prettyShow x) x+      -- t4 x = trace ("purednf' (" ++ prettyShow fm ++ ") -> " ++ prettyShow x) x++simpcnf' :: (atom ~ AtomOf fof, term ~ TermOf atom, predicate ~ PredOf atom, v ~ VarOf fof, v ~ TVarOf term, function ~ FunOf term,+             IsFirstOrder fof, Ord fof) => fof -> Set (Set fof)+simpcnf' fm =+    foldQuantified (\_ _ _ -> go) (\_ _ _ -> go) (\_ -> go) tf (\_ -> go) fm+    where+      tf False = Set.empty+      tf True = Set.singleton Set.empty+      go = let cjs = Set.filter (not . trivial) (purecnf' fm) in+           Set.filter (\c -> not (setAny (\c' -> Set.isProperSubsetOf c' c) cjs)) cjs++purecnf' :: (atom ~ AtomOf fof, term ~ TermOf atom, predicate ~ PredOf atom, v ~ VarOf fof, v ~ TVarOf term, function ~ FunOf term,+             IsFirstOrder fof, Ord fof) => fof -> Set (Set fof)+purecnf' fm = Set.map (Set.map negate) (purednf' (nnf ((.~.) fm)))++testSkolem :: Test+testSkolem = TestLabel "Skolem" (TestList [test01, test02, test03, test04, test05])
+ src/Data/Logic/ATP/Tableaux.hs view
@@ -0,0 +1,660 @@+-- | Tableaux, seen as an optimized version of a Prawitz-like procedure.+--+-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall #-}++module Data.Logic.ATP.Tableaux+    ( prawitz+    , K(K)+    , tab+    , testTableaux+    ) where++import Data.Logic.ATP.Apply (HasApply(TermOf), pApp)+import Control.Monad.RWS (RWS)+import Control.Monad.State (execStateT, StateT)+import Data.List as List (map)+import Data.Logic.ATP.FOL (asubst, fv, generalize, IsFirstOrder, subst)+import Data.Logic.ATP.Formulas (atomic, IsFormula(asBool, AtomOf), onatoms, overatoms)+import Data.Logic.ATP.Herbrand (davisputnam)+import Data.Logic.ATP.Lib ((|=>), allpairs, deepen, Depth(Depth), distrib, evalRS, Failing(Success, Failure), failing, settryfind, tryfindM)+import Data.Logic.ATP.Lit ((.~.), IsLiteral, JustLiteral, LFormula, positive)+import Data.Logic.ATP.Pretty (assertEqual', Pretty(pPrint), prettyShow, text)+import Data.Logic.ATP.Prop ( (.&.), (.=>.), (.<=>.), (.|.), BinOp((:&:), (:|:)), PFormula, simpdnf)+import Data.Logic.ATP.Quantified (exists, foldQuantified, for_all, Quant((:!:)))+import Data.Logic.ATP.Skolem (askolemize, Formula, HasSkolem(SVarOf, toSkolem), runSkolem, simpdnf', skolemize, SkTerm)+import Data.Logic.ATP.Term (fApp, IsTerm(TVarOf, FunOf), vt)+import Data.Logic.ATP.Unif (Unify, unify_literals)+import Data.Map.Strict as Map+import Data.Set as Set+import Data.String (IsString(..))+import Prelude hiding (compare)+import Test.HUnit hiding (State)++-- | Unify complementary literals.+unify_complements :: (IsLiteral lit, HasApply atom, Unify atom v term,+                      atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+                     lit -> lit -> StateT (Map v term) Failing ()+unify_complements p q = unify_literals p ((.~.) q)++-- | Unify and refute a set of disjuncts.+unify_refute :: (IsLiteral lit, Ord lit, HasApply atom, Unify atom v term, IsTerm term,+                 atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+                Set (Set lit) -> Map v term -> Failing (Map v term)+unify_refute djs env =+    case Set.minView djs of+      Nothing -> Success env+      Just (d, odjs) ->+          settryfind (\ (p, n) -> execStateT (unify_complements p n) env >>= 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 lit atom v term.+                (JustLiteral lit, Ord lit, HasApply atom, Unify atom v term,+                 atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+                Set (Set lit) -> [v] -> Set (Set lit) -> Int -> (Map v term, Int)+prawitz_loop djs0 fvs djs n =+    let inst = Map.fromList (zip fvs (List.map newvar [1..]))+        djs1 = distrib (Set.map (Set.map (onatoms (asubst 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+      newvar k = vt (fromString ("_" ++ show (n * length fvs + k)))++prawitz :: forall formula atom term function v.+           (IsFirstOrder formula, Ord formula, Unify atom v term, HasSkolem function, Show formula,+            atom ~ AtomOf formula, term ~ TermOf atom, function ~ FunOf term,+            v ~ TVarOf term, v ~ SVarOf function) =>+           formula -> Int+prawitz fm =+    snd (prawitz_loop dnf (Set.toList fvs) dnf0 0)+    where+      dnf0 = Set.singleton Set.empty+      dnf = (simpdnf id pf :: Set (Set (LFormula atom)))+      fvs = overatoms (\ a s -> Set.union (fv (atomic a :: formula)) s) pf (Set.empty :: Set v)+      pf = runSkolem (skolemize id ((.~.)(generalize fm))) :: PFormula atom++-- -------------------------------------------------------------------------+-- Examples.+-- -------------------------------------------------------------------------++p20 :: Test+p20 = TestCase $ assertEqual' "p20 - prawitz (p. 175)" expected input+    where fm :: Formula+          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"]))+          input = prawitz fm+          expected = 2++-- -------------------------------------------------------------------------+-- Comparison of number of ground instances.+-- -------------------------------------------------------------------------++compare :: (IsFirstOrder formula, Ord formula, Unify atom v term, HasSkolem function, Show formula,+            atom ~ AtomOf formula, term ~ TermOf atom, function ~ FunOf term,+            v ~ TVarOf term, v ~ SVarOf function) =>+           formula -> (Int, Int)+compare fm = (prawitz fm, davisputnam fm)++p19 :: Test+p19 = TestCase $ assertEqual' "p19" expected input+    where+      fm :: Formula+      fm = exists "x" (for_all "y" (for_all "z" ((pApp "P" [vt "y"] .=>. pApp "Q" [vt "z"]) .=>. pApp "P" [vt "x"] .=>. pApp "Q" [vt "x"])))+      input = compare fm+      expected = (3, 3)++{-+START_INTERACTIVE;;+let p20 = compare+ <<(for_all x y. exists z. for_all w. P[vt "x"] .&. Q[vt "y"] .=>. R[vt "z"] .&. U[vt "w"])+   .=>. (exists x y. P[vt "x"] .&. Q[vt "y"]) .=>. (exists z. R[vt "z"])>>;;++let p24 = compare+ <<~(exists x. U[vt "x"] .&. Q[vt "x"]) .&.+   (for_all x. P[vt "x"] .=>. Q[vt "x"] .|. R[vt "x"]) .&.+   ~(exists x. P[vt "x"] .=>. (exists x. Q[vt "x"])) .&.+   (for_all x. Q[vt "x"] .&. R[vt "x"] .=>. U[vt "x"])+   .=>. (exists x. P[vt "x"] .&. R[vt "x"])>>;;++let p39 = compare+ <<~(exists x. for_all y. P(y,x) .<=>. ~P(y,y))>>;;++let p42 = compare+ <<~(exists y. for_all x. P(x,y) .<=>. ~(exists z. P(x,z) .&. P(z,x)))>>;;++{- **** Too slow?++let p43 = compare+ <<(for_all x y. Q(x,y) .<=>. for_all z. P(z,x) .<=>. P(z,y))+   .=>. for_all x y. Q(x,y) .<=>. Q(y,x)>>;;++ ***** -}++let p44 = compare+ <<(for_all 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"] .&. (for_all y. G[vt "y"] .=>. H(x,y)))+   .=>. (exists x. J[vt "x"] .&. ~P[vt "x"])>>;;++let p59 = compare+ <<(for_all x. P[vt "x"] .<=>. ~P(f[vt "x"])) .=>. (exists x. P[vt "x"] .&. ~P(f[vt "x"]))>>;;++let p60 = compare+ <<for_all x. P(x,f[vt "x"]) .<=>.+             exists y. (for_all z. P(z,y) .=>. P(z,f[vt "x"])) .&. P(x,y)>>;;++END_INTERACTIVE;;+-}++newtype K = K Int deriving (Eq, Ord, Show)++instance Enum K where+    toEnum = K+    fromEnum (K n) = n++instance Pretty K where+    pPrint (K n) = text ("K" ++ show n)++-- | More standard tableau procedure, effectively doing DNF incrementally.  (p. 177)+tableau :: forall formula atom term v function.+           (IsFirstOrder formula, Unify atom v term,+            atom ~ AtomOf formula, term ~ TermOf atom, function ~ FunOf term, v ~ TVarOf term) =>+           [formula] -> Depth -> RWS () () () (Failing (K, Map v term))+tableau fms n0 =+    go (fms, [], n0) (return . Success) (K 0, Map.empty)+    where+      go :: ([formula], [formula], Depth)+         -> ((K, Map v term) -> RWS () () () (Failing (K, Map v term)))+         -> (K, Map v term)+         -> RWS () () () (Failing (K, Map v term))+      go (_, _, n) _ (_, _) | n < Depth 0 = return $ Failure ["no proof at this level"]+      go ([], _, _) _ (_, _) =  return $ Failure ["tableau: no proof"]+      go (fm : unexp, lits, n) cont (k, env) =+          foldQuantified qu co (\_ -> go2 fm unexp) (\_ -> go2 fm unexp) (\_ -> go2 fm unexp) fm+          where+            qu :: Quant -> v -> formula -> RWS () () () (Failing (K, Map v term))+            qu (:!:) x p =+                let y = vt (fromString (prettyShow k))+                    p' = subst (x |=> y) p in+                go ([p'] ++ unexp ++ [for_all x p],lits,pred n) cont (succ k, env)+            qu _ _ _ = go2 fm unexp+            co p (:&:) q =+                go (p : q : unexp,lits,n) cont (k, env)+            co p (:|:) q =+                go (p : unexp,lits,n) (go (q : unexp,lits,n) cont) (k, env)+            co _ _ _ = go2 fm unexp++            go2 :: formula -> [formula] -> RWS () () () (Failing (K, Map v term))+            go2 fm' unexp' =+                tryfindM (tryLit fm') lits >>=+                failing (\_ -> go (unexp', fm' : lits, n) cont (k, env))+                        (return . Success)+            tryLit :: formula -> formula -> RWS () () () (Failing (K, Map v term))+            tryLit fm' l = failing (return . Failure) (\env' -> cont (k, env')) (execStateT (unify_complements fm' l) env)++tabrefute :: (IsFirstOrder formula, Unify atom v term,+              atom ~ AtomOf formula, term ~ TermOf atom, v ~ TVarOf term) =>+             Maybe Depth -> [formula] -> Failing ((K, Map v term), Depth)+tabrefute limit fms =+    let r = deepen (\n -> (,n) <$> evalRS (tableau fms n) () ()) (Depth 0) limit in+    failing Failure (Success . fst) r++tab :: (IsFirstOrder formula, Unify atom v term, Pretty formula, HasSkolem function,+        atom ~ AtomOf formula, term ~ TermOf atom, function ~ FunOf term,+        v ~ TVarOf term, v ~ SVarOf function) =>+       Maybe Depth -> formula -> Failing ((K, Map v term), Depth)+tab limit fm =+  let sfm = runSkolem (askolemize((.~.)(generalize fm))) in+  if asBool sfm == Just False then (error "Tableaux.tab") else tabrefute limit [sfm]++p38 :: Test+p38 =+    let [p, r] = [pApp "P", pApp "R"] :: [[SkTerm] -> Formula]+        [a, w, x, y, z] = [vt "a", vt "w", vt "x", vt "y", vt "z"] :: [SkTerm]+        fm = (for_all "x"+               (p[a] .&. (p[x] .=>. (exists "y" (p[y] .&. r[x,y]))) .=>.+                (exists "z" (exists "w" (p[z] .&. r[x,w] .&. r[w,z]))))) .<=>.+             (for_all "x"+              (((.~.)(p[a]) .|. p[x] .|. (exists "z" (exists "w" (p[z] .&. r[x,w] .&. r[w,z])))) .&.+               ((.~.)(p[a]) .|. (.~.)(exists "y" (p[y] .&. r[x,y])) .|.+               (exists "z" (exists "w" (p[z] .&. r[x,w] .&. r[w,z]))))))+        expected = Success ((K 22,+                             Map.fromList+                                      [("K0",fApp ((toSkolem "x" 1))[]),+                                       ("K1",fApp ((toSkolem "y" 1))[]),+                                       ("K10",fApp ((toSkolem "x" 2))[]),+                                       ("K11",fApp ((toSkolem "z" 3))["K13"]),+                                       ("K12",fApp ((toSkolem "w" 3))["K16"]),+                                       ("K13",fApp ((toSkolem "x" 2))[]),+                                       ("K14",fApp ((toSkolem "y" 2))[]),+                                       ("K15",fApp ((toSkolem "y" 2))[]),+                                       ("K16",fApp ((toSkolem "x" 2))[]),+                                       ("K17",fApp ((toSkolem "y" 2))[]),+                                       ("K18",fApp ((toSkolem "y" 2))[]),+                                       ("K19",fApp ((toSkolem "x" 2))[]),+                                       ("K2",fApp ((toSkolem "z" 1))["K0"]),+                                       ("K20",fApp ((toSkolem "y" 2))[]),+                                       ("K21",fApp ((toSkolem "y" 2))[]),+                                       ("K3",fApp ((toSkolem "w" 1))["K0"]),+                                       ("K4",fApp ((toSkolem "z" 1))["K0"]),+                                       ("K5",fApp ((toSkolem "w" 1))["K0"]),+                                       ("K6",fApp ((toSkolem "z" 2))["K8"]),+                                       ("K7",fApp ((toSkolem "w" 2))["K9"]),+                                       ("K8",fApp ((toSkolem "x" 2))[]),+                                       ("K9",fApp ((toSkolem "x" 2))[])]+                                      ),+                            Depth 4) in+    TestCase $ assertEqual' "p38, p. 178" expected (tab Nothing fm)+{-+-- -------------------------------------------------------------------------+-- Example.+-- -------------------------------------------------------------------------++START_INTERACTIVE;;+let p38 = tab+ <<(for_all x.+     P[vt "a"] .&. (P[vt "x"] .=>. (exists y. P[vt "y"] .&. R(x,y))) .=>.+     (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))) .<=>.+   (for_all x.+     (~P[vt "a"] .|. P[vt "x"] .|. (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))) .&.+     (~P[vt "a"] .|. ~(exists y. P[vt "y"] .&. R(x,y)) .|.+     (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))))>>;;+END_INTERACTIVE;;+-}++-- -------------------------------------------------------------------------+-- Try to split up the initial formula first; often a big improvement.+-- -------------------------------------------------------------------------+splittab :: forall formula atom term v function.+            (IsFirstOrder formula, Unify atom v term, Ord formula, Pretty formula, HasSkolem function,+             atom ~ AtomOf formula, term ~ TermOf atom, function ~ FunOf term,+             v ~ TVarOf term, v ~ SVarOf function) =>+            formula -> [Failing ((K, Map v term), Depth)]+splittab fm =+    (List.map (tabrefute Nothing) . ssll . simpdnf' . runSkolem . askolemize . (.~.) . generalize) fm+    where ssll = List.map Set.toList . Set.toList+          -- simpdnf' :: PFormula atom -> Set (Set (LFormula atom))+          -- simpdnf' = simpdnf id++{-+-- -------------------------------------------------------------------------+-- Example: the Andrews challenge.+-- -------------------------------------------------------------------------++START_INTERACTIVE;;+let p34 = splittab+ <<((exists x. for_all y. P[vt "x"] .<=>. P[vt "y"]) .<=>.+    ((exists x. Q[vt "x"]) .<=>. (for_all y. Q[vt "y"]))) .<=>.+   ((exists x. for_all y. Q[vt "x"] .<=>. Q[vt "y"]) .<=>.+    ((exists x. P[vt "x"]) .<=>. (for_all y. P[vt "y"])))>>;;++-- -------------------------------------------------------------------------+-- Another nice example from EWD 1602.+-- -------------------------------------------------------------------------++let ewd1062 = splittab+ <<(for_all x. x <= x) .&.+   (for_all x y z. x <= y .&. y <= z .=>. x <= z) .&.+   (for_all x y. f[vt "x"] <= y .<=>. x <= g[vt "y"])+   .=>. (for_all x y. x <= y .=>. f[vt "x"] <= f[vt "y"]) .&.+       (for_all x y. x <= y .=>. g[vt "x"] <= g[vt "y"])>>;;+END_INTERACTIVE;;++-- -------------------------------------------------------------------------+-- Do all the equality-free Pelletier problems, and more, as examples.+-- -------------------------------------------------------------------------++{- **********++let p1 = time splittab+ <<p .=>. q .<=>. ~q .=>. ~p>>;;++let p2 = time splittab+ <<~ ~p .<=>. p>>;;++let p3 = time splittab+ <<~(p .=>. q) .=>. q .=>. p>>;;++let p4 = time splittab+ <<~p .=>. q .<=>. ~q .=>. p>>;;++let p5 = time splittab+ <<(p .|. q .=>. p .|. r) .=>. p .|. (q .=>. r)>>;;++let p6 = time splittab+ <<p .|. ~p>>;;++let p7 = time splittab+ <<p .|. ~ ~ ~p>>;;++let p8 = time splittab+ <<((p .=>. q) .=>. p) .=>. p>>;;++let p9 = time splittab+ <<(p .|. q) .&. (~p .|. q) .&. (p .|. ~q) .=>. ~(~q .|. ~q)>>;;++let p10 = time splittab+ <<(q .=>. r) .&. (r .=>. p .&. q) .&. (p .=>. q .&. r) .=>. (p .<=>. q)>>;;++let p11 = time splittab+ <<p .<=>. p>>;;++let p12 = time splittab+ <<((p .<=>. q) .<=>. r) .<=>. (p .<=>. (q .<=>. r))>>;;++let p13 = time splittab+ <<p .|. q .&. r .<=>. (p .|. q) .&. (p .|. r)>>;;++let p14 = time splittab+ <<(p .<=>. q) .<=>. (q .|. ~p) .&. (~q .|. p)>>;;++let p15 = time splittab+ <<p .=>. q .<=>. ~p .|. q>>;;++let p16 = time splittab+ <<(p .=>. q) .|. (q .=>. p)>>;;++let p17 = time splittab+ <<p .&. (q .=>. r) .=>. s .<=>. (~p .|. q .|. s) .&. (~p .|. ~r .|. s)>>;;++-- -------------------------------------------------------------------------+-- Pelletier problems: monadic predicate logic.+-- -------------------------------------------------------------------------++let p18 = time splittab+ <<exists y. for_all x. P[vt "y"] .=>. P[vt "x"]>>;;++let p19 = time splittab+ <<exists x. for_all y z. (P[vt "y"] .=>. Q[vt "z"]) .=>. P[vt "x"] .=>. Q[vt "x"]>>;;++let p20 = time splittab+ <<(for_all x y. exists z. for_all w. P[vt "x"] .&. Q[vt "y"] .=>. R[vt "z"] .&. U[vt "w"])+   .=>. (exists x y. P[vt "x"] .&. Q[vt "y"]) .=>. (exists z. R[vt "z"])>>;;++let p21 = time splittab+ <<(exists x. P .=>. Q[vt "x"]) .&. (exists x. Q[vt "x"] .=>. P)+   .=>. (exists x. P .<=>. Q[vt "x"])>>;;++let p22 = time splittab+ <<(for_all x. P .<=>. Q[vt "x"]) .=>. (P .<=>. (for_all x. Q[vt "x"]))>>;;++let p23 = time splittab+ <<(for_all x. P .|. Q[vt "x"]) .<=>. P .|. (for_all x. Q[vt "x"])>>;;++let p24 = time splittab+ <<~(exists x. U[vt "x"] .&. Q[vt "x"]) .&.+   (for_all x. P[vt "x"] .=>. Q[vt "x"] .|. R[vt "x"]) .&.+   ~(exists x. P[vt "x"] .=>. (exists x. Q[vt "x"])) .&.+   (for_all x. Q[vt "x"] .&. R[vt "x"] .=>. U[vt "x"]) .=>.+   (exists x. P[vt "x"] .&. R[vt "x"])>>;;++let p25 = time splittab+ <<(exists x. P[vt "x"]) .&.+   (for_all x. U[vt "x"] .=>. ~G[vt "x"] .&. R[vt "x"]) .&.+   (for_all x. P[vt "x"] .=>. G[vt "x"] .&. U[vt "x"]) .&.+   ((for_all x. P[vt "x"] .=>. Q[vt "x"]) .|. (exists x. Q[vt "x"] .&. P[vt "x"]))+   .=>. (exists x. Q[vt "x"] .&. P[vt "x"])>>;;++let p26 = time splittab+ <<((exists x. P[vt "x"]) .<=>. (exists x. Q[vt "x"])) .&.+   (for_all x y. P[vt "x"] .&. Q[vt "y"] .=>. (R[vt "x"] .<=>. U[vt "y"]))+   .=>. ((for_all x. P[vt "x"] .=>. R[vt "x"]) .<=>. (for_all x. Q[vt "x"] .=>. U[vt "x"]))>>;;++let p27 = time splittab+ <<(exists x. P[vt "x"] .&. ~Q[vt "x"]) .&.+   (for_all x. P[vt "x"] .=>. R[vt "x"]) .&.+   (for_all x. U[vt "x"] .&. V[vt "x"] .=>. P[vt "x"]) .&.+   (exists x. R[vt "x"] .&. ~Q[vt "x"])+   .=>. (for_all x. U[vt "x"] .=>. ~R[vt "x"])+       .=>. (for_all x. U[vt "x"] .=>. ~V[vt "x"])>>;;++let p28 = time splittab+ <<(for_all x. P[vt "x"] .=>. (for_all x. Q[vt "x"])) .&.+   ((for_all x. Q[vt "x"] .|. R[vt "x"]) .=>. (exists x. Q[vt "x"] .&. R[vt "x"])) .&.+   ((exists x. R[vt "x"]) .=>. (for_all x. L[vt "x"] .=>. M[vt "x"])) .=>.+   (for_all x. P[vt "x"] .&. L[vt "x"] .=>. M[vt "x"])>>;;++let p29 = time splittab+ <<(exists x. P[vt "x"]) .&. (exists x. G[vt "x"]) .=>.+   ((for_all x. P[vt "x"] .=>. H[vt "x"]) .&. (for_all x. G[vt "x"] .=>. J[vt "x"]) .<=>.+    (for_all x y. P[vt "x"] .&. G[vt "y"] .=>. H[vt "x"] .&. J[vt "y"]))>>;;++let p30 = time splittab+ <<(for_all x. P[vt "x"] .|. G[vt "x"] .=>. ~H[vt "x"]) .&.+   (for_all x. (G[vt "x"] .=>. ~U[vt "x"]) .=>. P[vt "x"] .&. H[vt "x"])+   .=>. (for_all x. U[vt "x"])>>;;++let p31 = time splittab+ <<~(exists x. P[vt "x"] .&. (G[vt "x"] .|. H[vt "x"])) .&.+   (exists x. Q[vt "x"] .&. P[vt "x"]) .&.+   (for_all x. ~H[vt "x"] .=>. J[vt "x"])+   .=>. (exists x. Q[vt "x"] .&. J[vt "x"])>>;;++let p32 = time splittab+ <<(for_all x. P[vt "x"] .&. (G[vt "x"] .|. H[vt "x"]) .=>. Q[vt "x"]) .&.+   (for_all x. Q[vt "x"] .&. H[vt "x"] .=>. J[vt "x"]) .&.+   (for_all x. R[vt "x"] .=>. H[vt "x"])+   .=>. (for_all x. P[vt "x"] .&. R[vt "x"] .=>. J[vt "x"])>>;;++let p33 = time splittab+ <<(for_all x. P[vt "a"] .&. (P[vt "x"] .=>. P[vt "b"]) .=>. P[vt "c"]) .<=>.+   (for_all 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. for_all y. P[vt "x"] .<=>. P[vt "y"]) .<=>.+    ((exists x. Q[vt "x"]) .<=>. (for_all y. Q[vt "y"]))) .<=>.+   ((exists x. for_all y. Q[vt "x"] .<=>. Q[vt "y"]) .<=>.+    ((exists x. P[vt "x"]) .<=>. (for_all y. P[vt "y"])))>>;;++let p35 = time splittab+ <<exists x y. P(x,y) .=>. (for_all x y. P(x,y))>>;;++-- -------------------------------------------------------------------------+-- Full predicate logic (without identity and functions).+-- -------------------------------------------------------------------------++let p36 = time splittab+ <<(for_all x. exists y. P(x,y)) .&.+   (for_all x. exists y. G(x,y)) .&.+   (for_all x y. P(x,y) .|. G(x,y)+   .=>. (for_all z. P(y,z) .|. G(y,z) .=>. H(x,z)))+       .=>. (for_all x. exists y. H(x,y))>>;;++let p37 = time splittab+ <<(for_all z.+     exists w. for_all x. exists y. (P(x,z) .=>. P(y,w)) .&. P(y,z) .&.+     (P(y,w) .=>. (exists u. Q(u,w)))) .&.+   (for_all x z. ~P(x,z) .=>. (exists y. Q(y,z))) .&.+   ((exists x y. Q(x,y)) .=>. (for_all x. R(x,x))) .=>.+   (for_all x. exists y. R(x,y))>>;;++let p38 = time splittab+ <<(for_all x.+     P[vt "a"] .&. (P[vt "x"] .=>. (exists y. P[vt "y"] .&. R(x,y))) .=>.+     (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))) .<=>.+   (for_all x.+     (~P[vt "a"] .|. P[vt "x"] .|. (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))) .&.+     (~P[vt "a"] .|. ~(exists y. P[vt "y"] .&. R(x,y)) .|.+     (exists z w. P[vt "z"] .&. R(x,w) .&. R(w,z))))>>;;++let p39 = time splittab+ <<~(exists x. for_all y. P(y,x) .<=>. ~P(y,y))>>;;++let p40 = time splittab+ <<(exists y. for_all x. P(x,y) .<=>. P(x,x))+  .=>. ~(for_all x. exists y. for_all z. P(z,y) .<=>. ~P(z,x))>>;;++let p41 = time splittab+ <<(for_all z. exists y. for_all x. P(x,y) .<=>. P(x,z) .&. ~P(x,x))+  .=>. ~(exists z. for_all x. P(x,z))>>;;++let p42 = time splittab+ <<~(exists y. for_all x. P(x,y) .<=>. ~(exists z. P(x,z) .&. P(z,x)))>>;;++let p43 = time splittab+ <<(for_all x y. Q(x,y) .<=>. for_all z. P(z,x) .<=>. P(z,y))+   .=>. for_all x y. Q(x,y) .<=>. Q(y,x)>>;;++let p44 = time splittab+ <<(for_all 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"] .&. (for_all y. G[vt "y"] .=>. H(x,y))) .=>.+   (exists x. J[vt "x"] .&. ~P[vt "x"])>>;;++let p45 = time splittab+ <<(for_all x.+     P[vt "x"] .&. (for_all y. G[vt "y"] .&. H(x,y) .=>. J(x,y)) .=>.+       (for_all y. G[vt "y"] .&. H(x,y) .=>. R[vt "y"])) .&.+   ~(exists y. L[vt "y"] .&. R[vt "y"]) .&.+   (exists x. P[vt "x"] .&. (for_all y. H(x,y) .=>.+     L[vt "y"]) .&. (for_all 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+ <<(for_all x. P[vt "x"] .&. (for_all 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"] .&.+               (for_all y. P[vt "y"] .&. ~G[vt "y"] .=>. J(x,y)))) .&.+   (for_all x y. P[vt "x"] .&. P[vt "y"] .&. H(x,y) .=>. ~J(y,x)) .=>.+   (for_all x. P[vt "x"] .=>. G[vt "x"])>>;;++-- -------------------------------------------------------------------------+-- Well-known "Agatha" example; cf. Manthey and Bry, CADE-9.+-- -------------------------------------------------------------------------++let p55 = time splittab+ <<lives(agatha) .&. lives(butler) .&. lives(charles) .&.+   (killed(agatha,agatha) .|. killed(butler,agatha) .|.+    killed(charles,agatha)) .&.+   (for_all x y. killed(x,y) .=>. hates(x,y) .&. ~richer(x,y)) .&.+   (for_all x. hates(agatha,x) .=>. ~hates(charles,x)) .&.+   (hates(agatha,agatha) .&. hates(agatha,charles)) .&.+   (for_all x. lives[vt "x"] .&. ~richer(x,agatha) .=>. hates(butler,x)) .&.+   (for_all x. hates(agatha,x) .=>. hates(butler,x)) .&.+   (for_all x. ~hates(x,agatha) .|. ~hates(x,butler) .|. ~hates(x,charles))+   .=>. killed(agatha,agatha) .&.+       ~killed(butler,agatha) .&.+       ~killed(charles,agatha)>>;;++let p57 = time splittab+ <<P(f([vt "a"],b),f(b,c)) .&.+   P(f(b,c),f(a,c)) .&.+   (for_all [vt "x"] y z. P(x,y) .&. P(y,z) .=>. P(x,z))+   .=>. P(f(a,b),f(a,c))>>;;++-- -------------------------------------------------------------------------+-- See info-hol, circa 1500.+-- -------------------------------------------------------------------------++let p58 = time splittab+ <<for_all P Q R. for_all x. exists v. exists w. for_all y. for_all z.+    ((P[vt "x"] .&. Q[vt "y"]) .=>. ((P[vt "v"] .|. R[vt "w"])  .&. (R[vt "z"] .=>. Q[vt "v"])))>>;;++let p59 = time splittab+ <<(for_all x. P[vt "x"] .<=>. ~P(f[vt "x"])) .=>. (exists x. P[vt "x"] .&. ~P(f[vt "x"]))>>;;++let p60 = time splittab+ <<for_all x. P(x,f[vt "x"]) .<=>.+            exists y. (for_all z. P(z,y) .=>. P(z,f[vt "x"])) .&. P(x,y)>>;;++-- -------------------------------------------------------------------------+-- From Gilmore's classic paper.+-- -------------------------------------------------------------------------++{- **** This is still too hard for us! Amazing...++let gilmore_1 = time splittab+ <<exists x. for_all y z.+      ((F[vt "y"] .=>. G[vt "y"]) .<=>. F[vt "x"]) .&.+      ((F[vt "y"] .=>. H[vt "y"]) .<=>. G[vt "x"]) .&.+      (((F[vt "y"] .=>. G[vt "y"]) .=>. H[vt "y"]) .<=>. H[vt "x"])+      .=>. F[vt "z"] .&. G[vt "z"] .&. H[vt "z"]>>;;++ ***** -}++{- ** This is not valid, according to Gilmore++let gilmore_2 = time splittab+ <<exists x y. for_all z.+        (F(x,z) .<=>. F(z,y)) .&. (F(z,y) .<=>. F(z,z)) .&. (F(x,y) .<=>. F(y,x))+        .=>. (F(x,y) .<=>. F(x,z))>>;;++ ** -}++let gilmore_3 = time splittab+ <<exists x. for_all y z.+        ((F(y,z) .=>. (G[vt "y"] .=>. H[vt "x"])) .=>. F(x,x)) .&.+        ((F(z,x) .=>. G[vt "x"]) .=>. H[vt "z"]) .&.+        F(x,y)+        .=>. F(z,z)>>;;++let gilmore_4 = time splittab+ <<exists x y. for_all z.+        (F(x,y) .=>. F(y,z) .&. F(z,z)) .&.+        (F(x,y) .&. G(x,y) .=>. G(x,z) .&. G(z,z))>>;;++let gilmore_5 = time splittab+ <<(for_all x. exists y. F(x,y) .|. F(y,x)) .&.+   (for_all x y. F(y,x) .=>. F(y,y))+   .=>. exists z. F(z,z)>>;;++let gilmore_6 = time splittab+ <<for_all x. exists y.+        (exists u. for_all v. F(u,x) .=>. G(v,u) .&. G(u,x))+        .=>. (exists u. for_all v. F(u,y) .=>. G(v,u) .&. G(u,y)) .|.+            (for_all u v. exists w. G(v,u) .|. H(w,y,u) .=>. G(u,w))>>;;++let gilmore_7 = time splittab+ <<(for_all x. K[vt "x"] .=>. exists y. L[vt "y"] .&. (F(x,y) .=>. G(x,y))) .&.+   (exists z. K[vt "z"] .&. for_all 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. for_all y z.+        ((F(y,z) .=>. (G[vt "y"] .=>. (for_all u. exists v. H(u,v,x)))) .=>. F(x,x)) .&.+        ((F(z,x) .=>. G[vt "x"]) .=>. (for_all u. exists v. H(u,v,z))) .&.+        F(x,y)+        .=>. F(z,z)>>;;++let gilmore_9 = time splittab+ <<for_all x. exists y. for_all z.+        ((for_all u. exists v. F(y,u,v) .&. G(y,u) .&. ~H(y,x))+          .=>. (for_all u. exists v. F(x,u,v) .&. G(z,u) .&. ~H(x,z))+          .=>. (for_all u. exists v. F(x,u,v) .&. G(y,u) .&. ~H(x,y))) .&.+        ((for_all u. exists v. F(x,u,v) .&. G(y,u) .&. ~H(x,y))+         .=>. ~(for_all u. exists v. F(x,u,v) .&. G(z,u) .&. ~H(x,z))+         .=>. (for_all u. exists v. F(y,u,v) .&. G(y,u) .&. ~H(y,x)) .&.+             (for_all u. exists v. F(z,u,v) .&. G(y,u) .&. ~H(z,y)))>>;;++-- -------------------------------------------------------------------------+-- Example from Davis-Putnam papers where Gilmore procedure is poor.+-- -------------------------------------------------------------------------++let davis_putnam_example = time splittab+ <<exists x. exists y. for_all z.+        (F(x,y) .=>. (F(y,z) .&. F(z,z))) .&.+        ((F(x,y) .&. G(x,y)) .=>. (G(x,z) .&. G(z,z)))>>;;++************ -}++-}++testTableaux :: Test+testTableaux = TestLabel "Tableaux" (TestList [p20, p19, p38])
+ src/Data/Logic/ATP/Term.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Logic.ATP.Term+    ( -- * Variables+      IsVariable(variant, prefix)+    , variants+    --, showVariable+    , V(V)+    -- * Functions+    , IsFunction+    , Arity+    , FName(FName)+    -- * Terms+    , IsTerm(TVarOf, FunOf, vt, fApp, foldTerm)+    , zipTerms+    , convertTerm+    , precedenceTerm+    , associativityTerm+    , prettyTerm+    , prettyFunctionApply+    , showTerm+    , showFunctionApply+    , funcs+    , Term(Var, FApply)+    , FTerm+    , testTerm+    ) where++import Data.Data (Data)+import Data.Logic.ATP.Pretty ((<>), Associativity(InfixN), Doc, HasFixity(associativity, precedence), Precedence, prettyShow, text)+import Data.Set as Set (empty, insert, member, Set, singleton)+import Data.String (IsString(fromString))+import Data.Typeable (Typeable)+import Prelude hiding (pred)+import Text.PrettyPrint (parens, brackets, punctuate, comma, fsep, space)+import Text.PrettyPrint.HughesPJClass (maybeParens, Pretty(pPrint, pPrintPrec), PrettyLevel, prettyNormal)+import Test.HUnit++---------------+-- VARIABLES --+---------------++class (Ord v, IsString v, Pretty v, Show v) => IsVariable v where+    variant :: v -> Set v -> v+    -- ^ Return a variable based on v but different from any set+    -- element.  The result may be v itself if v is not a member of+    -- the set.+    prefix :: String -> v -> v+    -- ^ Modify a variable by adding a prefix.  This unfortunately+    -- assumes that v is "string-like" but at least one algorithm in+    -- Harrison currently requires this.++-- | Return an infinite list of variations on v+variants :: IsVariable v => v -> [v]+variants v0 =+    loop Set.empty v0+    where loop s v = let v' = variant v s in v' : loop (Set.insert v s) v'++-- | Because IsString is a superclass we can just output a string expression+showVariable :: IsVariable v => v -> String+showVariable v = show (prettyShow v)++newtype V = V String deriving (Eq, Ord, Data, Typeable, Read)++instance IsVariable String where+    variant v vs = if Set.member v vs then variant (v ++ "'") vs else v+    prefix pre s = pre ++ s++instance IsVariable V where+    variant v@(V s) vs = if Set.member v vs then variant (V (s ++ "'")) vs else v+    prefix pre (V s) = V (pre ++ s)++instance IsString V where+    fromString = V++instance Show V where+    show (V s) = show s++instance Pretty V where+    pPrint (V s) = text s++---------------+-- FUNCTIONS --+---------------++class (IsString function, Ord function, Pretty function, Show function) => IsFunction function++type Arity = Int++-- | A simple type to use as the function parameter of Term.  The only+-- reason to use this instead of String is to get nicer pretty+-- printing.+newtype FName = FName String deriving (Eq, Ord)++instance IsFunction FName++instance IsString FName where fromString = FName++instance Show FName where show (FName s) = s++instance Pretty FName where pPrint (FName s) = text s++-----------+-- TERMS --+-----------++-- | A term is an expression representing a domain element, either as+-- a variable reference or a function applied to a list of terms.+class (Eq term, Ord term, Pretty term, Show term, IsString term, HasFixity term,+       IsVariable (TVarOf term), IsFunction (FunOf term)) => IsTerm term where+    type TVarOf term+    -- ^ The associated variable type+    type FunOf term+    -- ^ The associated function type+    vt :: TVarOf term -> term+    -- ^ Build a term which is a variable reference.+    fApp :: FunOf term -> [term] -> term+    -- ^ Build a term by applying terms to an atomic function ('FunOf' @term@).+    foldTerm :: (TVarOf term -> r)          -- ^ Variable references are dispatched here+             -> (FunOf term -> [term] -> r) -- ^ Function applications are dispatched here+             -> term -> r+    -- ^ A fold over instances of 'IsTerm'.++-- | Combine two terms if they are similar (i.e. two variables or+-- two function applications.)+zipTerms :: (IsTerm term1, v1 ~ TVarOf term1, function1 ~ FunOf term1,+             IsTerm term2, v2 ~ TVarOf term2, function2 ~ FunOf term2) =>+            (v1 -> v2 -> Maybe r) -- ^ Combine two variables+         -> (function1 -> [term1] -> function2 -> [term2] -> Maybe r) -- ^ Combine two function applications+         -> term1+         -> term2+         -> Maybe r -- ^ Result for dissimilar terms is 'Nothing'.+zipTerms v ap t1 t2 =+    foldTerm v' ap' t1+    where+      v' v1 =      foldTerm     (v v1)   (\_ _ -> Nothing) t2+      ap' p1 ts1 = foldTerm (\_ -> Nothing) (\p2 ts2 -> if length ts1 == length ts2 then ap p1 ts1 p2 ts2 else Nothing)   t2++-- | Convert between two instances of IsTerm+convertTerm :: (IsTerm term1, v1 ~ TVarOf term1, f1 ~ FunOf term1,+                IsTerm term2, v2 ~ TVarOf term2, f2 ~ FunOf term2) =>+               (v1 -> v2) -- ^ convert a variable+            -> (f1 -> f2) -- ^ convert a function+            -> term1 -> term2+convertTerm cv cf = foldTerm (vt . cv) (\f ts -> fApp (cf f) (map (convertTerm cv cf) ts))++precedenceTerm :: IsTerm term => term -> Precedence+precedenceTerm = const 0++associativityTerm :: IsTerm term => term -> Associativity+associativityTerm = const InfixN++-- | Implementation of pPrint for any term+prettyTerm :: (v ~ TVarOf term, function ~ FunOf term, IsTerm term, HasFixity term, Pretty v, Pretty function) =>+              PrettyLevel -> Rational -> term -> Doc+prettyTerm l r tm = maybeParens (l > prettyNormal || r > precedence tm) (foldTerm pPrint (prettyFunctionApply l) tm)++-- | Format a function application: F(x,y)+prettyFunctionApply :: (function ~ FunOf term, IsTerm term, HasFixity term) => PrettyLevel -> function -> [term] -> Doc+prettyFunctionApply _l f [] = pPrint f+prettyFunctionApply l f ts = pPrint f <> parens (fsep (punctuate comma (map (prettyTerm l 0) ts)))++-- | Implementation of show for any term+showTerm :: (v ~ TVarOf term, function ~ FunOf term, IsTerm term, Pretty v, Pretty function) => term -> String+showTerm = foldTerm showVariable showFunctionApply++-- | Build an expression for a function application: fApp (F) [x, y]+showFunctionApply :: (v ~ TVarOf term, function ~ FunOf term, IsTerm term) => function -> [term] -> String+showFunctionApply f ts = "fApp (" <> show f <> ")" <> show (brackets (fsep (punctuate (comma <> space) (map (text . show) ts))))++funcs :: (IsTerm term, function ~ FunOf term) => term -> Set (function, Arity)+funcs = foldTerm (\_ -> Set.empty) (\f ts -> Set.singleton (f, length ts))++data Term function v+    = Var v+    | FApply function [Term function v]+    deriving (Eq, Ord, Data, Typeable, Read)++instance (IsVariable v, IsFunction function) => IsString (Term function v) where+    fromString = Var . fromString++instance (IsVariable v, IsFunction function) => Show (Term function v) where+    show = showTerm++instance (IsFunction function, IsVariable v) => HasFixity (Term function v) where+    precedence = precedenceTerm+    associativity = associativityTerm++instance (IsFunction function, IsVariable v) => IsTerm (Term function v) where+    type TVarOf (Term function v) = v+    type FunOf (Term function v) = function+    vt = Var+    fApp = FApply+    foldTerm vf fn t =+        case t of+          Var v -> vf v+          FApply f ts -> fn f ts++instance (IsTerm (Term function v)) => Pretty (Term function v) where+    pPrintPrec = prettyTerm++-- | A term type with no Skolem functions+type FTerm = Term FName V++-- Example.+test00 :: Test+test00 = TestCase $ assertEqual "print an expression"+                                "sqrt(-(1, cos(power(+(x, y), 2))))"+                                (prettyShow (fApp "sqrt" [fApp "-" [fApp "1" [],+                                                                     fApp "cos" [fApp "power" [fApp "+" [Var "x", Var "y"],+                                                                                               fApp "2" []]]]] :: Term FName V))++testTerm :: Test+testTerm = TestLabel "Term" (TestList [test00])
+ src/Data/Logic/ATP/Unif.hs view
@@ -0,0 +1,190 @@+-- | Unification for first order terms.+--+-- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.)++{-# OPTIONS -Wall #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Logic.ATP.Unif+    ( Unify(unify)+    , unify_terms+    , unify_literals+    , unify_atoms+    , unify_atoms_eq+    , solve+    , fullunify+    , unify_and_apply+    , testUnif+    ) where++import Control.Monad.State -- (evalStateT, runStateT, State, StateT, get)+import Data.Bool (bool)+import Data.List as List (map)+import Data.Logic.ATP.Apply (HasApply(TermOf), JustApply, zipApplys)+import Data.Logic.ATP.Equate (HasEquate, zipEquates)+import Data.Logic.ATP.FOL (tsubst)+import Data.Logic.ATP.Formulas (IsFormula(AtomOf))+import Data.Logic.ATP.Lib (Failing(Success, Failure))+import Data.Logic.ATP.Lit (IsLiteral, zipLiterals')+import Data.Logic.ATP.Skolem (SkAtom, SkTerm)+import Data.Logic.ATP.Term (IsTerm(..), V)+import Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Sequence (Seq, viewl, ViewL(EmptyL, (:<)))+import Test.HUnit hiding (State)++-- | Main unification procedure.+class Unify a v term where+    unify :: a -> a -> StateT (Map v term) Failing ()+    -- ^ Unify the two elements of a pair, collecting variable+    -- assignments in the state.++instance Unify a v term => Unify [a] v term where+    unify [] [] = return ()+    unify (x : xs) (y : ys) = unify x y >> unify xs ys+    unify _ _ = fail "unify - list length mismatch"++instance Unify a v term => Unify (Seq a) v term where+    unify xs ys =+        case (viewl xs, viewl ys) of+          (EmptyL, EmptyL) -> return ()+          (x :< xs', y :< ys') -> unify x y >> unify xs' ys'+          _ -> fail "unify - Seq list length mismatch"++unify_terms :: (IsTerm term, v ~ TVarOf term) => [(term,term)] -> StateT (Map v term) Failing ()+unify_terms = mapM_ (uncurry unify_term_pair)++unify_term_pair :: forall term v f. (IsTerm term, v ~ TVarOf term, f ~ FunOf term) =>+                   term -> term -> StateT (Map v term) Failing ()+unify_term_pair a b =+    foldTerm (vr b) (\ f fargs -> foldTerm (vr a) (fn f fargs) b) a+    where+      vr :: term -> v -> StateT (Map v term) Failing ()+      vr t x =+          (Map.lookup x <$> get) >>=+          maybe (istriv x t >>= bool (modify (Map.insert x t)) (return ()))+                (\y -> unify_term_pair y t)+      fn :: f -> [term] -> f -> [term] -> StateT (Map v term) Failing ()+      fn f fargs g gargs =+          if f == g && length fargs == length gargs+          then mapM_ (uncurry unify_term_pair) (zip fargs gargs)+          else fail "impossible unification"++istriv :: forall term v. (IsTerm term, v ~ TVarOf term) =>+          v -> term -> StateT (Map v term) Failing Bool+istriv x t =+    foldTerm vr fn t+    where+      -- vr :: v -> StateT (Map v term) Failing Bool+      vr y | x == y = return True+      vr y = (Map.lookup y <$> get) >>= maybe (return False) (istriv x)+      -- fn :: f -> [term] -> StateT (Map v term) Failing Bool+      fn _ args = mapM (istriv x) args >>= bool (return False) (fail "cyclic") . or++-- | Solve to obtain a single instantiation.+solve :: (IsTerm term, v ~ TVarOf term, f ~ FunOf term) =>+         Map v term -> Map v term+solve env =+    if env' == env then env else solve env'+    where env' = Map.map (tsubst env) env++-- | Unification reaching a final solved form (often this isn't needed).+fullunify :: (IsTerm term, v ~ TVarOf term, f ~ FunOf term) =>+             [(term,term)] -> Failing (Map v term)+fullunify eqs = solve <$> execStateT (unify_terms eqs) Map.empty++-- | Examples.+unify_and_apply :: (IsTerm term, v ~ TVarOf term, f ~ FunOf term) =>+                   [(term, term)] -> Failing [(term, term)]+unify_and_apply eqs =+    fullunify eqs >>= \i -> return $ List.map (\ (t1, t2) -> (tsubst i t1, tsubst i t2)) eqs++-- | Unify literals+unify_literals :: (IsLiteral lit, HasApply atom, Unify atom v term,+                   atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) =>+                  lit -> lit -> StateT (Map v term) Failing ()+unify_literals f1 f2 =+    fromMaybe (fail "Can't unify literals") (zipLiterals' ho ne tf at f1 f2)+    where+      ho _ _ = Nothing+      ne p q = Just $ unify_literals p q+      tf p q = if p == q then Just (unify_terms []) else Nothing+      at a1 a2 = Just (unify a1 a2)++unify_atoms :: (JustApply atom, term ~ TermOf atom, v ~ TVarOf term) =>+               (atom, atom) -> StateT (Map v term) Failing ()+unify_atoms (a1, a2) =+    maybe (fail "unify_atoms") id (zipApplys (\_ tpairs -> Just (unify_terms tpairs)) a1 a2)++unify_atoms_eq :: (HasEquate atom, term ~ TermOf atom, v ~ TVarOf term) =>+                  atom -> atom -> StateT (Map v term) Failing ()+unify_atoms_eq a1 a2 =+    maybe (fail "unify_atoms") id (zipEquates (\l1 r1 l2 r2 -> Just (unify_terms [(l1, l2), (r1, r2)]))+                                              (\_ tpairs -> Just (unify_terms tpairs))+                                              a1 a2)++--unify_and_apply' :: (v ~ TVarOf term, f ~ FunOf term, IsTerm term) => [(term, term)] -> Failing [(term, term)]+--unify_and_apply' eqs =+--    mapM app eqs+--        where+--          app (t1, t2) = fullunify eqs >>= \i -> return $ (tsubst i t1, tsubst i t2)++instance Unify SkAtom V SkTerm where+    unify = unify_atoms_eq++test01, test02, test03, test04 :: Test+test01 = TestCase (assertEqual "Unify test 1"+                     (Success [(f [f [z],g [y]],+                                f [f [z],g [y]])]) -- expected+                     (unify_and_apply [(f [x, g [y]], f [f [z], w])]))+    where+      [f, g] = [fApp "f", fApp "g"]+      [w, x, y, z] = [vt "w", vt "x", vt "y", vt "z"] :: [SkTerm]+test02 = TestCase (assertEqual "Unify test 2"+                     (Success [(f [y,y],+                                f [y,y])]) -- expected+                     (unify_and_apply [(f [x, y], f [y, x])]))+    where+      [f] = [fApp "f"]+      [x, y] = [vt "x", vt "y"] :: [SkTerm]+test03 = TestCase (assertEqual "Unify test 3"+                     (Failure ["cyclic"]) -- expected+                     (unify_and_apply [(f [x, g [y]], f [y, x])]))+    where+      [f, g] = [fApp "f", fApp "g"]+      [x, y] = [vt "x", vt "y"] :: [SkTerm]+test04 = TestCase (assertEqual "Unify test 4"+                     (Success [(f [f [f [x_3,x_3],f [x_3,x_3]], f [f [x_3,x_3],f [x_3,x_3]]],+                                f [f [f [x_3,x_3],f [x_3,x_3]], f [f [x_3,x_3],f [x_3,x_3]]]),+                               (f [f [x_3,x_3],f [x_3,x_3]],+                                f [f [x_3,x_3],f [x_3,x_3]]),+                               (f [x_3,x_3],+                                f [x_3,x_3])]) -- expected+                     (unify_and_apply [(x_0, f [x_1, x_1]),+                                       (x_1, f [x_2, x_2]),+                                       (x_2, f [x_3, x_3])]))++    where+      f = fApp "f"+      [x_0, x_1, x_2, x_3] = [vt "x0", vt "x1", vt "x2", vt "x3"] :: [SkTerm]+{-++START_INTERACTIVE;;+unify_and_apply [<<|f(x,g(y))|>>,<<|f(f(z),w)|>>];;++unify_and_apply [<<|f(x,y)|>>,<<|f(y,x)|>>];;++(****  unify_and_apply [<<|f(x,g(y))|>>,<<|f(y,x)|>>];; *****)++unify_and_apply [<<|x_0|>>,<<|f(x_1,x_1)|>>;+                 <<|x_1|>>,<<|f(x_2,x_2)|>>;+                 <<|x_2|>>,<<|f(x_3,x_3)|>>];;+END_INTERACTIVE;;+-}++testUnif :: Test+testUnif = TestLabel "Unif" (TestList [test01, test02, test03, test04])
+ tests/Extra.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE GADTs, MultiParamTypeClasses, OverloadedStrings, QuasiQuotes, ScopedTypeVariables, TemplateHaskell #-}+module Extra where++import Data.List as List (map)+import Data.Logic.ATP.Apply (pApp)+import Data.Logic.ATP.Equate ((.=.))+import Data.Logic.ATP.Formulas+import Data.Logic.ATP.Lib (Depth(Depth), Failing(Failure, Success))+import Data.Logic.ATP.Lit ((.~.))+import Data.Logic.ATP.Meson (meson)+import Data.Logic.ATP.Pretty (prettyShow, testEquals)+import Data.Logic.ATP.Prop hiding (nnf)+import Data.Logic.ATP.Quantified (for_all, exists)+import Data.Logic.ATP.Parser (fof)+import Data.Logic.ATP.Resolution+import Data.Logic.ATP.Skolem (Formula, HasSkolem(toSkolem), skolemize, runSkolem, SkAtom, SkTerm)+import Data.Logic.ATP.Tableaux (K(K), tab)+import Data.Logic.ATP.Term (vt, fApp)+import Data.Map as Map (empty)+import Data.Set as Set (fromList, minView, null, Set, singleton)+import Data.String (fromString)+import Test.HUnit++testExtra :: Test+testExtra = TestList [test01, test02, test05, test06, test07]++test05 :: Test+test05 = TestLabel "Socrates syllogism" $ 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+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+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")++test06 :: Test+test06 =+    let fm :: Formula+        fm = for_all "x" (vt "x" .=. vt "x") .=>. for_all "x" (exists "y" (vt "x" .=. vt "y"))+        expected :: PFormula SkAtom+        expected =  (vt "x" .=. vt "x") .&. (.~.) (fApp (toSkolem "x" 1) [] .=. vt "x")+        -- atoms = [applyPredicate equals [(vt ("x" :: V)) (vt "x")] {-, (fApp (toSkolem "x" 1)[]) .=. (vt "x")-}] :: [SkAtom]+        sk = runSkolem (skolemize id ((.~.) fm)) :: PFormula SkAtom+        table = truthTable sk :: TruthTable SkAtom in+    TestLabel "∀x. x = x ⇒ ∀x. ∃y. x = y" $ TestCase $ assertEqual "∀x. x = x ⇒ ∀x. ∃y. x = y"+                           (expected,+                            TruthTable+                              (List.map asAtom ([vt "x" .=. vt "x", fApp (toSkolem "x" 1) [] .=. vt "x"] :: [Formula]))+                              [([False,False],False),+                               ([False,True],False),+                               ([True,False],True),+                               ([True,True],False)] :: TruthTable SkAtom,+                           Set.fromList [Success (Depth 1)])+                           (sk, table, runSkolem (meson Nothing fm))++asAtom :: forall formula. IsFormula formula => formula -> AtomOf formula+asAtom fm = case Set.minView (atom_union singleton fm :: Set (AtomOf formula)) of+              Just (a, s) | Set.null s -> a+              _ -> error "asAtom"++mesonTest :: (String, Formula, Set (Failing Depth)) -> Test+mesonTest (label, fm, expected) =+    let me = runSkolem (meson (Just (Depth 1000)) fm) in+    TestLabel label $ TestCase $ assertEqual ("MESON test: " ++ prettyShow fm) expected me++fms :: [(String, Formula, Set (Failing Depth))]+fms = [ let [x, y] = [vt "x", vt "y"] :: [SkTerm] in+        ("if x every x equals itself then there is always some y that equals x",+         for_all "x" (x .=. x) .=>. for_all "x" (exists "y" (x .=. y)),+         Set.fromList [Success (Depth 1)]),+        let x = vt "x" :: SkTerm+            [s, h, m] = [pApp "S", pApp "H", pApp "M"] :: [[SkTerm] -> Formula] in+        ("Socrates is a human, all humans are mortal, therefore socrates is mortal",+         (for_all "x" (s [x] .=>. h [x]) .&. for_all "x" (h [x] .=>. m [x])) .=>. for_all "x" (s [x] .=>. m [x]),+         Set.fromList [Success (Depth 3)]) ]++test07 :: Test+test07 = TestList (List.map mesonTest fms)++test01 :: Test+test01 = let fm1 = [fof| ∀a. ¬(P(a)∧(∀y. (∀z. Q(y)∨R(z))∧¬P(a))) |] :: Formula in+         $(testEquals "MESON 1") ([fof| ∀a. ¬(P(a)∧(∀y. (∀z. Q(y)∨R(z))∧¬P(a))) |], Success ((K 2, Map.empty),Depth 2))+              (fm1, tab Nothing fm1)+test02 :: Test+test02 = let fm2 = [fof| ∀a. ¬(P(a)∧¬P(a)∧(∀y z. Q(y)∨R(z))) |] :: Formula in+         $(testEquals "MESON 2") ([fof| ∀a. ¬(P(a)∧¬P(a)∧(∀y z. Q(y)∨R(z))) |], Success ((K 0, Map.empty),Depth 0))+              (fm2, tab Nothing fm2)+{-+i = for_all "a" ((.~.)(p[a] .&. (for_all "y" (for_all "z" (q[y] .|. r[z]) .&. (.~.)(p[a])))))++a = (for_all "a" ((.~.) (((pApp (fromString "P")["a"]) .&. (for_all "y" (for_all "z"+                                                                         (((pApp (fromString "Q")["y"]) .|.+                                                                           (pApp (fromString "R")["z"])) .&.+                                                                          ((.~.) ((pApp (fromString "P")["a"]))))))))))+b = (for_all "a" ((.~.) (((pApp (fromString "P")["a"]) .&. (for_all "y" ((for_all "z"+                                                                          ((pApp (fromString "Q")["y"]) .|.+                                                                           (pApp (fromString "R")["z"]))) .&.+                                                                         ((.~.) ((pApp (fromString "P")["a"])))))))))+-}+{-+test12 :: Test+test12 =+    let fm = (let (x, y) = (vt "x" :: Term, vt "y" :: Term) in ((for_all "x" ((x .=. x))) .=>. (for_all "x" (exists "y" ((x .=. y))))) :: Formula FOL) in+    TestCase $ assertEqual "∀x. x = x ⇒ ∀x. ∃y. x = y" (holds fm) True+-}
+ tests/Main.hs view
@@ -0,0 +1,41 @@+import Test.HUnit++import Data.Logic.ATP.DefCNF (testDefCNF)+import Data.Logic.ATP.DP (testDP)+import Data.Logic.ATP.FOL (testFOL)+import Data.Logic.ATP.Herbrand (testHerbrand)+import Data.Logic.ATP.Lib (testLib)+import Data.Logic.ATP.Prop (testProp)+import Data.Logic.ATP.PropExamples (testPropExamples)+import Data.Logic.ATP.Skolem (testSkolem)+import Data.Logic.ATP.ParserTests (testParser)+import Data.Logic.ATP.Unif (testUnif)+import Data.Logic.ATP.Tableaux (testTableaux)+import Data.Logic.ATP.Resolution (testResolution)+import Data.Logic.ATP.Prolog (testProlog)+import Data.Logic.ATP.Meson (testMeson)+import Data.Logic.ATP.Equal (testEqual)+import Extra (testExtra)++import System.Exit (exitWith, ExitCode(ExitSuccess, ExitFailure))++main :: IO Counts+main = runTestTT (TestList  [TestLabel "Lib" testLib,+                             TestLabel "Prop" testProp,+                             TestLabel "PropExamples" testPropExamples,+                             TestLabel "DefCNF" testDefCNF,+                             TestLabel "DP" testDP,+                             TestLabel "FOL" testFOL,+                             TestLabel "Skolem" testSkolem,+                             TestLabel "Parser" testParser,+                             TestLabel "Herbrand" testHerbrand,+                             TestLabel "Unif" testUnif,+                             TestLabel "Tableaux" testTableaux,+                             TestLabel "Resolution" testResolution,+                             TestLabel "Prolog" testProlog,+                             TestLabel "Meson" testMeson,+                             TestLabel "Equal" testEqual,+                             TestLabel "Extra" testExtra+                             ]) >>= doCounts+    where+      doCounts counts' = exitWith (if errors counts' /= 0 || failures counts' /= 0 then ExitFailure 1 else ExitSuccess)