diff --git a/.ghci b/.ghci new file mode 100644 --- /dev/null +++ b/.ghci @@ -0,0 +1,8 @@ +:set -isrc:tests +:set -XCPP +:set -XOverloadedStrings +:set -XFlexibleContexts +:set -XFlexibleInstances +:set -XQuasiQuotes +:set prompt "λ " +:load Data.Logic.ATP diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -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 diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/atp-haskell.cabal b/atp-haskell.cabal new file mode 100644 --- /dev/null +++ b/atp-haskell.cabal @@ -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 +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 diff --git a/src/Data/Logic/ATP.hs b/src/Data/Logic/ATP.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP.hs @@ -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 diff --git a/src/Data/Logic/ATP/Apply.hs b/src/Data/Logic/ATP/Apply.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Apply.hs @@ -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 diff --git a/src/Data/Logic/ATP/DP.hs b/src/Data/Logic/ATP/DP.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/DP.hs @@ -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]) diff --git a/src/Data/Logic/ATP/DefCNF.hs b/src/Data/Logic/ATP/DefCNF.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/DefCNF.hs @@ -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]) diff --git a/src/Data/Logic/ATP/Equal.hs b/src/Data/Logic/ATP/Equal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Equal.hs @@ -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 + < f(c) = c>>;; + +time meson fm;; + +let fm = + < achain(s,t)) /\ + (forall s t. cong(s,t) ==> cchain(s,t)) /\ + (forall s t u. axiom(s,t) /\ (t = u) ==> achain(s,u)) /\ + (forall s t u. cong(s,t) /\ achain(t,u) ==> cchain(s,u)) /\ + (forall s t. cchain(s,t) ==> s = t) /\ + (forall s t. achain(s,t) ==> s = t) /\ + (forall t. t = t) /\ + (forall x y. x = y ==> cong(f(x),f(y))) + ==> f(c) = c>>;; + +time meson fm;; + +-- ------------------------------------------------------------------------- +-- With stratified equalities. +-- ------------------------------------------------------------------------- + +let fm = + <<(forall x y z. eqA (x * (y * z),(x * y) * z)) /\ + (forall x y z. eqA ((x * y) * z)) /\ + (forall x. eqA (1 * x,x)) /\ + (forall x. eqA (x,1 * x)) /\ + (forall x. eqA (i(x) * x,1)) /\ + (forall x. eqA (1,i(x) * x)) /\ + (forall x. eqA (x,x)) /\ + (forall x y. eqA (x,y) ==> eqC (i(x),i(y))) /\ + (forall x y. eqC (x,y) ==> eqC (i(x),i(y))) /\ + (forall x y. eqT (x,y) ==> eqC (i(x),i(y))) /\ + (forall w x y z. eqA (w,x) /\ eqA (y,z) ==> eqC (w * y,x * z)) /\ + (forall w x y z. eqA (w,x) /\ eqC (y,z) ==> eqC (w * y,x * z)) /\ + (forall w x y z. eqA (w,x) /\ eqT (y,z) ==> eqC (w * y,x * z)) /\ + (forall w x y z. eqC (w,x) /\ eqA (y,z) ==> eqC (w * y,x * z)) /\ + (forall w x y z. eqC (w,x) /\ eqC (y,z) ==> eqC (w * y,x * z)) /\ + (forall w x y z. eqC (w,x) /\ eqT (y,z) ==> eqC (w * y,x * z)) /\ + (forall w x y z. eqT (w,x) /\ eqA (y,z) ==> eqC (w * y,x * z)) /\ + (forall w x y z. eqT (w,x) /\ eqC (y,z) ==> eqC (w * y,x * z)) /\ + (forall w x y z. eqT (w,x) /\ eqT (y,z) ==> eqC (w * y,x * z)) /\ + (forall x y z. eqA (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\ + (forall x y z. eqC (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\ + (forall x y z. eqA (x,y) /\ eqC (y,z) ==> eqT (x,z)) /\ + (forall x y z. eqA (x,y) /\ eqT (y,z) ==> eqT (x,z)) /\ + (forall x y z. eqC (x,y) /\ eqT (y,z) ==> eqT (x,z)) + ==> forall x. eqT (x * i(x),1)>>;; + +-- ------------------------------------------------------------------------- +-- With transitivity chains... +-- ------------------------------------------------------------------------- + +let fm = + <<(forall x y z. eqA (x * (y * z),(x * y) * z)) /\ + (forall x y z. eqA ((x * y) * z)) /\ + (forall x. eqA (1 * x,x)) /\ + (forall x. eqA (x,1 * x)) /\ + (forall x. eqA (i(x) * x,1)) /\ + (forall x. eqA (1,i(x) * x)) /\ + (forall x y. eqA (x,y) ==> eqC (i(x),i(y))) /\ + (forall x y. eqC (x,y) ==> eqC (i(x),i(y))) /\ + (forall w x y. eqA (w,x) ==> eqC (w * y,x * y)) /\ + (forall w x y. eqC (w,x) ==> eqC (w * y,x * y)) /\ + (forall x y z. eqA (y,z) ==> eqC (x * y,x * z)) /\ + (forall x y z. eqC (y,z) ==> eqC (x * y,x * z)) /\ + (forall x y z. eqA (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\ + (forall x y z. eqC (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\ + (forall x y z. eqA (x,y) /\ eqC (y,z) ==> eqT (x,z)) /\ + (forall x y z. eqC (x,y) /\ eqC (y,z) ==> eqT (x,z)) /\ + (forall x y z. eqA (x,y) /\ eqT (y,z) ==> eqT (x,z)) /\ + (forall x y z. eqC (x,y) /\ eqT (y,z) ==> eqT (x,z)) + ==> forall x. eqT (x * i(x),1) \/ eqC (x * i(x),1)>>;; + +time meson fm;; + +-- ------------------------------------------------------------------------- +-- Enforce canonicity (proof size = 20). +-- ------------------------------------------------------------------------- + +let fm = + <<(forall x y z. eq1(x * (y * z),(x * y) * z)) /\ + (forall x y z. eq1((x * y) * z,x * (y * z))) /\ + (forall x. eq1(1 * x,x)) /\ + (forall x. eq1(x,1 * x)) /\ + (forall x. eq1(i(x) * x,1)) /\ + (forall x. eq1(1,i(x) * x)) /\ + (forall x y z. eq1(x,y) ==> eq1(x * z,y * z)) /\ + (forall x y z. eq1(x,y) ==> eq1(z * x,z * y)) /\ + (forall x y z. eq1(x,y) /\ eq2(y,z) ==> eq2(x,z)) /\ + (forall x y. eq1(x,y) ==> eq2(x,y)) + ==> forall x. eq2(x,i(x))>>;; + +time meson fm;; + +***************** -} +END_INTERACTIVE;; +-} diff --git a/src/Data/Logic/ATP/Equate.hs b/src/Data/Logic/ATP/Equate.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Equate.hs @@ -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 diff --git a/src/Data/Logic/ATP/FOL.hs b/src/Data/Logic/ATP/FOL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/FOL.hs @@ -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. 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 <>;; + +holds (mod_interp 2) undefined <>;; + +holds (mod_interp 3) undefined <>;; + +let fm = < 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 < 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]) diff --git a/src/Data/Logic/ATP/Formulas.hs b/src/Data/Logic/ATP/Formulas.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Formulas.hs @@ -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 diff --git a/src/Data/Logic/ATP/Herbrand.hs b/src/Data/Logic/ATP/Herbrand.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Herbrand.hs @@ -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]) diff --git a/src/Data/Logic/ATP/Lib.hs b/src/Data/Logic/ATP/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Lib.hs @@ -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 "";; + +#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]) diff --git a/src/Data/Logic/ATP/Lit.hs b/src/Data/Logic/ATP/Lit.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Lit.hs @@ -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 diff --git a/src/Data/Logic/ATP/Meson.hs b/src/Data/Logic/ATP/Meson.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Meson.hs @@ -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 <>;; + +tab <>;; + +(* ------------------------------------------------------------------------- *) +(* The interesting example where tableaux connections make the proof longer. *) +(* Unfortuntely this gets hammered by normalization first... *) +(* ------------------------------------------------------------------------- *) + +tab <<~p /\ (p \/ q) /\ (r \/ s) /\ (~q \/ t \/ u) /\ + (~r \/ ~t) /\ (~r \/ ~u) /\ (~q \/ v \/ w) /\ + (~s \/ ~v) /\ (~s \/ ~w) ==> false>>;; +END_INTERACTIVE;; +-} +-- ------------------------------------------------------------------------- +-- 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]])))]])) +{- +[[<>]] +-} + (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]])))])) +{- +[<>] +-} + (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)) -> + <> +-} + +{- +START_INTERACTIVE;; +tab <>;; + +tab <>;; + +-- ------------------------------------------------------------------------- +-- The interesting example where tableaux connections make the proof longer. +-- Unfortuntely this gets hammered by normalization first... +-- ------------------------------------------------------------------------- + +tab <<~p /\ (p \/ q) /\ (r \/ s) /\ (~q \/ t \/ u) /\ + (~r \/ ~t) /\ (~r \/ ~u) /\ (~q \/ v \/ w) /\ + (~s \/ ~v) /\ (~s \/ ~w) ==> false>>;; +END_INTERACTIVE;; +-} + +-- ------------------------------------------------------------------------- +-- Generation of contrapositives. +-- ------------------------------------------------------------------------- + +contrapositives :: (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 + <

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

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

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

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

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

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

r) ==> s <=> (~p \/ q \/ s) /\ (~p \/ ~r \/ s)>>;; + +-- ------------------------------------------------------------------------- +-- Monadic Predicate Logic. +-- ------------------------------------------------------------------------- + +let p18 = time meson + < P(x)>>;; + +let p19 = time meson + < Q(z)) ==> P(x) ==> Q(x)>>;; + +let p20 = time meson + <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w)) ==> + (exists x y. P(x) /\ Q(y)) ==> + (exists z. R(z))>>;; + +let p21 = time meson + <<(exists x. P ==> Q(x)) /\ (exists x. Q(x) ==> P) + ==> (exists x. P <=> Q(x))>>;; + +let p22 = time meson + <<(forall x. P <=> Q(x)) ==> (P <=> (forall x. Q(x)))>>;; + +let p23 = time meson + <<(forall x. P \/ Q(x)) <=> P \/ (forall x. Q(x))>>;; + +let p24 = time meson + <<~(exists x. U(x) /\ Q(x)) /\ + (forall x. P(x) ==> Q(x) \/ R(x)) /\ + ~(exists x. P(x) ==> (exists x. Q(x))) /\ + (forall x. Q(x) /\ R(x) ==> U(x)) ==> + (exists x. P(x) /\ R(x))>>;; + +let p25 = time meson + <<(exists x. P(x)) /\ + (forall x. U(x) ==> ~G(x) /\ R(x)) /\ + (forall x. P(x) ==> G(x) /\ U(x)) /\ + ((forall x. P(x) ==> Q(x)) \/ (exists x. Q(x) /\ P(x))) ==> + (exists x. Q(x) /\ P(x))>>;; + +let p26 = time meson + <<((exists x. P(x)) <=> (exists x. Q(x))) /\ + (forall x y. P(x) /\ Q(y) ==> (R(x) <=> U(y))) ==> + ((forall x. P(x) ==> R(x)) <=> (forall x. Q(x) ==> U(x)))>>;; + +let p27 = time meson + <<(exists x. P(x) /\ ~Q(x)) /\ + (forall x. P(x) ==> R(x)) /\ + (forall x. U(x) /\ V(x) ==> P(x)) /\ + (exists x. R(x) /\ ~Q(x)) ==> + (forall x. U(x) ==> ~R(x)) ==> + (forall x. U(x) ==> ~V(x))>>;; + +let p28 = time meson + <<(forall x. P(x) ==> (forall x. Q(x))) /\ + ((forall x. Q(x) \/ R(x)) ==> (exists x. Q(x) /\ R(x))) /\ + ((exists x. R(x)) ==> (forall x. L(x) ==> M(x))) ==> + (forall x. P(x) /\ L(x) ==> M(x))>>;; + +let p29 = time meson + <<(exists x. P(x)) /\ (exists x. G(x)) ==> + ((forall x. P(x) ==> H(x)) /\ (forall x. G(x) ==> J(x)) <=> + (forall x y. P(x) /\ G(y) ==> H(x) /\ J(y)))>>;; + +let p30 = time meson + <<(forall x. P(x) \/ G(x) ==> ~H(x)) /\ (forall x. (G(x) ==> ~U(x)) ==> + P(x) /\ H(x)) ==> + (forall x. U(x))>>;; + +let p31 = time meson + <<~(exists x. P(x) /\ (G(x) \/ H(x))) /\ (exists x. Q(x) /\ P(x)) /\ + (forall x. ~H(x) ==> J(x)) ==> + (exists x. Q(x) /\ J(x))>>;; + +let p32 = time meson + <<(forall x. P(x) /\ (G(x) \/ H(x)) ==> Q(x)) /\ + (forall x. Q(x) /\ H(x) ==> J(x)) /\ + (forall x. R(x) ==> H(x)) ==> + (forall x. P(x) /\ R(x) ==> J(x))>>;; + +let p33 = time meson + <<(forall x. P(a) /\ (P(x) ==> P(b)) ==> P(c)) <=> + (forall x. P(a) ==> P(x) \/ P(c)) /\ (P(a) ==> P(b) ==> P(c))>>;; + +let p34 = time meson + <<((exists x. forall y. P(x) <=> P(y)) <=> + ((exists x. Q(x)) <=> (forall y. Q(y)))) <=> + ((exists x. forall y. Q(x) <=> Q(y)) <=> + ((exists x. P(x)) <=> (forall y. P(y))))>>;; + +let p35 = time meson + < (forall x y. P(x,y))>>;; + +-- ------------------------------------------------------------------------- +-- Full predicate logic (without Identity and Functions) +-- ------------------------------------------------------------------------- + +let p36 = time meson + <<(forall x. exists y. P(x,y)) /\ + (forall x. exists y. G(x,y)) /\ + (forall x y. P(x,y) \/ G(x,y) + ==> (forall z. P(y,z) \/ G(y,z) ==> H(x,z))) + ==> (forall x. exists y. H(x,y))>>;; + +let p37 = time meson + <<(forall z. + exists w. forall x. exists y. (P(x,z) ==> P(y,w)) /\ P(y,z) /\ + (P(y,w) ==> (exists u. Q(u,w)))) /\ + (forall x z. ~P(x,z) ==> (exists y. Q(y,z))) /\ + ((exists x y. Q(x,y)) ==> (forall x. R(x,x))) ==> + (forall x. exists y. R(x,y))>>;; + +let p38 = time meson + <<(forall x. + P(a) /\ (P(x) ==> (exists y. P(y) /\ R(x,y))) ==> + (exists z w. P(z) /\ R(x,w) /\ R(w,z))) <=> + (forall x. + (~P(a) \/ P(x) \/ (exists z w. P(z) /\ R(x,w) /\ R(w,z))) /\ + (~P(a) \/ ~(exists y. P(y) /\ R(x,y)) \/ + (exists z w. P(z) /\ R(x,w) /\ R(w,z))))>>;; + +let p39 = time meson + <<~(exists x. forall y. P(y,x) <=> ~P(y,y))>>;; + +let p40 = time meson + <<(exists y. forall x. P(x,y) <=> P(x,x)) + ==> ~(forall x. exists y. forall z. P(z,y) <=> ~P(z,x))>>;; + +let p41 = time meson + <<(forall z. exists y. forall x. P(x,y) <=> P(x,z) /\ ~P(x,x)) + ==> ~(exists z. forall x. P(x,z))>>;; + +let p42 = time meson + <<~(exists y. forall x. P(x,y) <=> ~(exists z. P(x,z) /\ P(z,x)))>>;; + +let p43 = time meson + <<(forall x y. Q(x,y) <=> forall z. P(z,x) <=> P(z,y)) + ==> forall x y. Q(x,y) <=> Q(y,x)>>;; + +let p44 = time meson + <<(forall x. P(x) ==> (exists y. G(y) /\ H(x,y)) /\ + (exists y. G(y) /\ ~H(x,y))) /\ + (exists x. J(x) /\ (forall y. G(y) ==> H(x,y))) ==> + (exists x. J(x) /\ ~P(x))>>;; + +let p45 = time meson + <<(forall x. + P(x) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y)) ==> + (forall y. G(y) /\ H(x,y) ==> R(y))) /\ + ~(exists y. L(y) /\ R(y)) /\ + (exists x. P(x) /\ (forall y. H(x,y) ==> + L(y)) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y))) ==> + (exists x. P(x) /\ ~(exists y. G(y) /\ H(x,y)))>>;; + +let p46 = time meson + <<(forall x. P(x) /\ (forall y. P(y) /\ H(y,x) ==> G(y)) ==> G(x)) /\ + ((exists x. P(x) /\ ~G(x)) ==> + (exists x. P(x) /\ ~G(x) /\ + (forall y. P(y) /\ ~G(y) ==> J(x,y)))) /\ + (forall x y. P(x) /\ P(y) /\ H(x,y) ==> ~J(y,x)) ==> + (forall x. P(x) ==> G(x))>>;; + +-- ------------------------------------------------------------------------- +-- Example from Manthey and Bry, CADE-9. +-- ------------------------------------------------------------------------- + +let p55 = time meson + < hates(x,y) /\ ~richer(x,y)) /\ + (forall x. hates(agatha,x) ==> ~hates(charles,x)) /\ + (hates(agatha,agatha) /\ hates(agatha,charles)) /\ + (forall x. lives(x) /\ ~richer(x,agatha) ==> hates(butler,x)) /\ + (forall x. hates(agatha,x) ==> hates(butler,x)) /\ + (forall x. ~hates(x,agatha) \/ ~hates(x,butler) \/ ~hates(x,charles)) + ==> killed(agatha,agatha) /\ + ~killed(butler,agatha) /\ + ~killed(charles,agatha)>>;; + +let p57 = time meson + < P(x,z)) + ==> P(f(a,b),f(a,c))>>;; + +-- ------------------------------------------------------------------------- +-- See info-hol, circa 1500. +-- ------------------------------------------------------------------------- + +let p58 = time meson + < ((P(v) \/ R(w)) /\ (R(z) ==> Q(v))))>>;; + +let p59 = time meson + <<(forall x. P(x) <=> ~P(f(x))) ==> (exists x. P(x) /\ ~P(f(x)))>>;; + +let p60 = time meson + < + exists y. (forall z. P(z,y) ==> P(z,f(x))) /\ P(x,y)>>;; + +-- ------------------------------------------------------------------------- +-- From Gilmore's classic paper. +-- ------------------------------------------------------------------------- + +{- ** Amazingly, this still seems non-trivial... in HOL it works at depth 45! + +let gilmore_1 = time meson + < G(y)) <=> F(x)) /\ + ((F(y) ==> H(y)) <=> G(x)) /\ + (((F(y) ==> G(y)) ==> H(y)) <=> H(x)) + ==> F(z) /\ G(z) /\ H(z)>>;; + + ** -} + +{- ** This is not valid, according to Gilmore + +let gilmore_2 = time meson + < F(z,y)) /\ (F(z,y) <=> F(z,z)) /\ (F(x,y) <=> F(y,x)) + ==> (F(x,y) <=> F(x,z))>>;; + + ** -} + +let gilmore_3 = time meson + < (G(y) ==> H(x))) ==> F(x,x)) /\ + ((F(z,x) ==> G(x)) ==> H(z)) /\ + F(x,y) + ==> F(z,z)>>;; + +let gilmore_4 = time meson + < F(y,z) /\ F(z,z)) /\ + (F(x,y) /\ G(x,y) ==> G(x,z) /\ G(z,z))>>;; + +let gilmore_5 = time meson + <<(forall x. exists y. F(x,y) \/ F(y,x)) /\ + (forall x y. F(y,x) ==> F(y,y)) + ==> exists z. F(z,z)>>;; + +let gilmore_6 = time meson + < G(v,u) /\ G(u,x)) + ==> (exists u. forall v. F(u,y) ==> G(v,u) /\ G(u,y)) \/ + (forall u v. exists w. G(v,u) \/ H(w,y,u) ==> G(u,w))>>;; + +let gilmore_7 = time meson + <<(forall x. K(x) ==> exists y. L(y) /\ (F(x,y) ==> G(x,y))) /\ + (exists z. K(z) /\ forall u. L(u) ==> F(z,u)) + ==> exists v w. K(v) /\ L(w) /\ G(v,w)>>;; + +let gilmore_8 = time meson + < (G(y) ==> (forall u. exists v. H(u,v,x)))) ==> F(x,x)) /\ + ((F(z,x) ==> G(x)) ==> (forall u. exists v. H(u,v,z))) /\ + F(x,y) + ==> F(z,z)>>;; + +{- ** This is still a very hard problem + +let gilmore_9 = time meson + < (forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z)) + ==> (forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y))) /\ + ((forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y)) + ==> ~(forall u. exists v. F(x,u,v) /\ G(z,u) /\ ~H(x,z)) + ==> (forall u. exists v. F(y,u,v) /\ G(y,u) /\ ~H(y,x)) /\ + (forall u. exists v. F(z,u,v) /\ G(y,u) /\ ~H(z,y)))>>;; + + ** -} + +-- ------------------------------------------------------------------------- +-- Translation of Gilmore procedure using separate definitions. +-- ------------------------------------------------------------------------- + +let gilmore_9a = time meson + <<(forall x y. P(x,y) <=> + forall u. exists v. F(x,u,v) /\ G(y,u) /\ ~H(x,y)) + ==> forall x. exists y. forall z. + (P(y,x) ==> (P(x,z) ==> P(x,y))) /\ + (P(x,y) ==> (~P(x,z) ==> P(y,x) /\ P(z,y)))>>;; + +-- ------------------------------------------------------------------------- +-- Example from Davis-Putnam papers where Gilmore procedure is poor. +-- ------------------------------------------------------------------------- + +let davis_putnam_example = time meson + < (F(y,z) /\ F(z,z))) /\ + ((F(x,y) /\ G(x,y)) ==> (G(x,z) /\ G(z,z)))>>;; + +-- ------------------------------------------------------------------------- +-- The "connections make things worse" example once again. +-- ------------------------------------------------------------------------- + +meson <<~p /\ (p \/ q) /\ (r \/ s) /\ (~q \/ t \/ u) /\ + (~r \/ ~t) /\ (~r \/ ~u) /\ (~q \/ v \/ w) /\ + (~s \/ ~v) /\ (~s \/ ~w) ==> false>>;; +END_INTERACTIVE;; +-} + +testMeson :: Test +testMeson = TestLabel "Meson" (TestList [test03, test04, test05, test01, test06, test02]) diff --git a/src/Data/Logic/ATP/Parser.hs b/src/Data/Logic/ATP/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Parser.hs @@ -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 = ["∃"] diff --git a/src/Data/Logic/ATP/ParserTests.hs b/src/Data/Logic/ATP/ParserTests.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/ParserTests.hs @@ -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 |]) + ]) diff --git a/src/Data/Logic/ATP/Pretty.hs b/src/Data/Logic/ATP/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Pretty.hs @@ -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 diff --git a/src/Data/Logic/ATP/Prolog.hs b/src/Data/Logic/ATP/Prolog.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Prolog.hs @@ -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 []) diff --git a/src/Data/Logic/ATP/Prop.hs b/src/Data/Logic/ATP/Prop.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Prop.hs @@ -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] diff --git a/src/Data/Logic/ATP/PropExamples.hs b/src/Data/Logic/ATP/PropExamples.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/PropExamples.hs @@ -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]) diff --git a/src/Data/Logic/ATP/Quantified.hs b/src/Data/Logic/ATP/Quantified.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Quantified.hs @@ -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 diff --git a/src/Data/Logic/ATP/Resolution.hs b/src/Data/Logic/ATP/Resolution.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Resolution.hs @@ -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 + <

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

. r) .=>. s .<=>. (~p .|. q .|. s) .&. (~p .|. ~r .|. s)>>;; + +-- ------------------------------------------------------------------------- +-- Pelletier problems: monadic predicate logic. +-- ------------------------------------------------------------------------- + +let p18 = time splittab + <. P[vt "x"]>>;; + +let p19 = time splittab + <. Q[vt "z"]) .=>. P[vt "x"] .=>. Q[vt "x"]>>;; + +let p20 = time splittab + <<(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 + <. (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 + <. 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(x,z)) + .=>. P(f(a,b),f(a,c))>>;; + +-- ------------------------------------------------------------------------- +-- See info-hol, circa 1500. +-- ------------------------------------------------------------------------- + +let p58 = time splittab + <. ((P[vt "v"] .|. R[vt "w"]) .&. (R[vt "z"] .=>. Q[vt "v"])))>>;; + +let p59 = time splittab + <<(for_all x. P[vt "x"] .<=>. ~P(f[vt "x"])) .=>. (exists x. P[vt "x"] .&. ~P(f[vt "x"]))>>;; + +let p60 = time splittab + <. + 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 + <. G[vt "y"]) .<=>. F[vt "x"]) .&. + ((F[vt "y"] .=>. H[vt "y"]) .<=>. G[vt "x"]) .&. + (((F[vt "y"] .=>. G[vt "y"]) .=>. H[vt "y"]) .<=>. H[vt "x"]) + .=>. F[vt "z"] .&. G[vt "z"] .&. H[vt "z"]>>;; + + ***** -} + +{- ** This is not valid, according to Gilmore + +let gilmore_2 = time splittab + <. F(z,y)) .&. (F(z,y) .<=>. F(z,z)) .&. (F(x,y) .<=>. F(y,x)) + .=>. (F(x,y) .<=>. F(x,z))>>;; + + ** -} + +let gilmore_3 = time splittab + <. (G[vt "y"] .=>. H[vt "x"])) .=>. F(x,x)) .&. + ((F(z,x) .=>. G[vt "x"]) .=>. H[vt "z"]) .&. + F(x,y) + .=>. F(z,z)>>;; + +let gilmore_4 = time splittab + <. F(y,z) .&. F(z,z)) .&. + (F(x,y) .&. G(x,y) .=>. G(x,z) .&. G(z,z))>>;; + +let gilmore_5 = time splittab + <<(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 + <. 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 + <. (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 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 + <. (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]) diff --git a/src/Data/Logic/ATP/Term.hs b/src/Data/Logic/ATP/Term.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Term.hs @@ -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]) diff --git a/src/Data/Logic/ATP/Unif.hs b/src/Data/Logic/ATP/Unif.hs new file mode 100644 --- /dev/null +++ b/src/Data/Logic/ATP/Unif.hs @@ -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]) diff --git a/tests/Extra.hs b/tests/Extra.hs new file mode 100644 --- /dev/null +++ b/tests/Extra.hs @@ -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 +-} diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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)