├── .ghci ├── .travis.yml ├── LICENSE.txt ├── Setup.hs ├── atp-haskell.cabal ├── src └── Data │ └── Logic │ ├── ATP.hs │ └── ATP │ ├── Apply.hs │ ├── DP.hs │ ├── DefCNF.hs │ ├── Equal.hs │ ├── Equate.hs │ ├── FOL.hs │ ├── Formulas.hs │ ├── Herbrand.hs │ ├── Lib.hs │ ├── Lit.hs │ ├── LitWrapper.hs │ ├── Meson.hs │ ├── Parser.hs │ ├── ParserTests.hs │ ├── Pretty.hs │ ├── Prolog.hs │ ├── Prop.hs │ ├── PropExamples.hs │ ├── Quantified.hs │ ├── Resolution.hs │ ├── Skolem.hs │ ├── Tableaux.hs │ ├── Term.hs │ └── Unif.hs └── tests ├── Extra.hs └── Main.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc:tests 2 | :set -XCPP 3 | :set -XOverloadedStrings 4 | :set -XFlexibleContexts 5 | :set -XFlexibleInstances 6 | :set -XQuasiQuotes 7 | :set prompt "λ " 8 | :load Data.Logic.ATP 9 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This file has been generated -- see https://github.com/hvr/multi-ghc-travis 2 | language: c 3 | sudo: false 4 | 5 | cache: 6 | directories: 7 | - $HOME/.cabsnap 8 | - $HOME/.cabal/packages 9 | 10 | before_cache: 11 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 12 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar 13 | 14 | matrix: 15 | include: 16 | - env: CABALVER=1.22 GHCVER=7.10.3 17 | compiler: ": #GHC 7.10.3" 18 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} 19 | - env: CABALVER=head GHCVER=head 20 | compiler: ": #GHC head" 21 | addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} 22 | 23 | allow_failures: 24 | - env: CABALVER=head GHCVER=head 25 | 26 | before_install: 27 | - unset CC 28 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 29 | 30 | install: 31 | - cabal --version 32 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 33 | - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; 34 | then 35 | zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > 36 | $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; 37 | fi 38 | - travis_retry cabal update -v 39 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 40 | - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt 41 | - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt 42 | 43 | # check whether current requested install-plan matches cached package-db snapshot 44 | - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; 45 | then 46 | echo "cabal build-cache HIT"; 47 | rm -rfv .ghc; 48 | cp -a $HOME/.cabsnap/ghc $HOME/.ghc; 49 | cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; 50 | else 51 | echo "cabal build-cache MISS"; 52 | rm -rf $HOME/.cabsnap; 53 | mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; 54 | cabal install --only-dependencies --enable-tests --enable-benchmarks; 55 | fi 56 | 57 | # snapshot package-db on cache miss 58 | - if [ ! -d $HOME/.cabsnap ]; 59 | then 60 | echo "snapshotting package-db to build-cache"; 61 | mkdir $HOME/.cabsnap; 62 | cp -a $HOME/.ghc $HOME/.cabsnap/ghc; 63 | cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; 64 | fi 65 | 66 | # Here starts the actual work to be performed for the package under test; 67 | # any command which exits with a non-zero exit code causes the build to fail. 68 | script: 69 | - if [ -f configure.ac ]; then autoreconf -i; fi 70 | - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging 71 | - cabal build # this builds all libraries and executables (including tests/benchmarks) 72 | - cabal test 73 | # - cabal check 74 | - cabal sdist # tests that a source-distribution can be generated 75 | 76 | # Check that the resulting source distribution can be built & installed. 77 | # If there are no other `.tar.gz` files in `dist`, this can be even simpler: 78 | # `cabal install --force-reinstalls dist/*-*.tar.gz` 79 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 80 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 81 | 82 | # EOF 83 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | IMPORTANT: READ BEFORE DOWNLOADING, COPYING, INSTALLING OR USING. 2 | By downloading, copying, installing or using the software you agree 3 | to this license. If you do not agree to this license, do not 4 | download, install, copy or use the software. 5 | 6 | Copyright (c) 2003-2007, John Harrison 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without 10 | modification, are permitted provided that the following conditions 11 | are met: 12 | 13 | * Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 16 | * Redistributions in binary form must reproduce the above copyright 17 | notice, this list of conditions and the following disclaimer in the 18 | documentation and/or other materials provided with the distribution. 19 | 20 | * The name of John Harrison may not be used to endorse or promote 21 | products derived from this software without specific prior written 22 | permission. 23 | 24 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 25 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 26 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 27 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 28 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 29 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 30 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF 31 | USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 32 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 33 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 34 | OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 35 | SUCH DAMAGE. 36 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /atp-haskell.cabal: -------------------------------------------------------------------------------- 1 | Name: atp-haskell 2 | Version: 1.14.3 3 | Synopsis: Translation from Ocaml to Haskell of John Harrison's ATP code 4 | Description: This package is a liberal translation from OCaml to Haskell of 5 | the automated theorem prover written in OCaml in 6 | John Harrison's book "Practical Logic and Automated 7 | Reasoning". Click on module ATP below for an overview. 8 | Homepage: https://github.com/seereason/atp-haskell 9 | License: BSD3 10 | License-File: LICENSE.txt 11 | Author: John Harrison 12 | Maintainer: David Fox 13 | Bug-Reports: https://github.com/seereason/atp-haskell/issues 14 | Category: Logic, Theorem Provers 15 | Cabal-version: >= 1.10 16 | Build-Type: Simple 17 | Extra-Source-Files: tests/Extra.hs, .travis.yml, .ghci 18 | Tested-With: GHC == 7.10.3, GHC == 7.11.*, GHC == 8.6.5, GHC == 9.8.2 19 | 20 | Source-Repository head 21 | type: git 22 | location: https://github.com/seereason/atp-haskell 23 | 24 | Library 25 | Default-Language: Haskell2010 26 | Build-Depends: 27 | applicative-extras, 28 | base >= 4.8 && < 5, 29 | containers, 30 | extra, 31 | HUnit, 32 | mtl, 33 | parsec, 34 | pretty >= 1.1.2, 35 | template-haskell, 36 | time 37 | GHC-options: -Wall 38 | Hs-Source-Dirs: src 39 | Exposed-Modules: 40 | Data.Logic.ATP 41 | Data.Logic.ATP.Lib 42 | Data.Logic.ATP.Pretty 43 | Data.Logic.ATP.Formulas 44 | Data.Logic.ATP.Term 45 | Data.Logic.ATP.Apply 46 | Data.Logic.ATP.Equate 47 | -- 48 | Data.Logic.ATP.Lit 49 | Data.Logic.ATP.LitWrapper 50 | Data.Logic.ATP.Prop 51 | Data.Logic.ATP.PropExamples 52 | Data.Logic.ATP.DefCNF 53 | Data.Logic.ATP.DP 54 | -- Data.Logic.ATP.Stal 55 | -- Data.Logic.ATP.BDD 56 | Data.Logic.ATP.Quantified 57 | Data.Logic.ATP.Parser 58 | Data.Logic.ATP.FOL 59 | Data.Logic.ATP.ParserTests 60 | Data.Logic.ATP.Skolem 61 | Data.Logic.ATP.Herbrand 62 | Data.Logic.ATP.Unif 63 | Data.Logic.ATP.Tableaux 64 | Data.Logic.ATP.Resolution 65 | Data.Logic.ATP.Prolog 66 | Data.Logic.ATP.Meson 67 | -- Data.Logic.ATP.Skolems 68 | Data.Logic.ATP.Equal 69 | -- Data.Logic.ATP.Cong 70 | -- Data.Logic.ATP.Rewrite 71 | -- Data.Logic.ATP.Order 72 | -- Data.Logic.ATP.Completion 73 | -- Data.Logic.ATP.Eqelim 74 | -- Data.Logic.ATP.Paramodulation 75 | -- 76 | -- Data.Logic.ATP.Decidable 77 | -- Data.Logic.ATP.Qelim 78 | -- Data.Logic.ATP.Cooper 79 | -- Data.Logic.ATP.Complex 80 | -- Data.Logic.ATP.Real 81 | -- Data.Logic.ATP.Grobner 82 | -- Data.Logic.ATP.Geom 83 | -- Data.Logic.ATP.Interpolation 84 | -- Data.Logic.ATP.Combining 85 | 86 | -- Data.Logic.ATP.Lcf 87 | -- Data.Logic.ATP.Lcfprop 88 | -- Data.Logic.ATP.Folderived 89 | -- Data.Logic.ATP.Lcffol 90 | -- Data.Logic.ATP.Tactics 91 | 92 | -- Data.Logic.ATP.Limitations 93 | 94 | Test-Suite atp-haskell-tests 95 | Default-Language: Haskell2010 96 | Type: exitcode-stdio-1.0 97 | Hs-Source-Dirs: tests 98 | Main-Is: Main.hs 99 | Build-Depends: atp-haskell, base, containers, HUnit, time 100 | GHC-options: -Wall -O2 101 | Other-Modules: Extra 102 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP.hs: -------------------------------------------------------------------------------- 1 | module Data.Logic.ATP 2 | ( module Data.Logic.ATP.Lib 3 | , module Data.Logic.ATP.Pretty 4 | , module Data.Logic.ATP.Formulas 5 | , module Data.Logic.ATP.Lit 6 | , module Data.Logic.ATP.Prop 7 | , module Data.Logic.ATP.PropExamples 8 | , module Data.Logic.ATP.DefCNF 9 | , module Data.Logic.ATP.DP 10 | , module Data.Logic.ATP.Term 11 | , module Data.Logic.ATP.Apply 12 | , module Data.Logic.ATP.Equate 13 | , module Data.Logic.ATP.Quantified 14 | , module Data.Logic.ATP.Parser 15 | , module Data.Logic.ATP.FOL 16 | , module Data.Logic.ATP.Skolem 17 | , module Data.Logic.ATP.Herbrand 18 | , module Data.Logic.ATP.Unif 19 | , module Data.Logic.ATP.Tableaux 20 | , module Data.Logic.ATP.Resolution 21 | , module Data.Logic.ATP.Prolog 22 | , module Data.Logic.ATP.Meson 23 | , module Data.Logic.ATP.Equal 24 | , module Text.PrettyPrint.HughesPJClass 25 | , module Test.HUnit 26 | ) where 27 | 28 | import Data.String ({-instances-}) 29 | import Text.PrettyPrint.HughesPJClass hiding ((<>)) 30 | 31 | import Data.Logic.ATP.Lib 32 | import Data.Logic.ATP.Pretty 33 | import Data.Logic.ATP.Formulas 34 | import Data.Logic.ATP.Lit hiding (Atom, T, F, Not) 35 | import Data.Logic.ATP.Prop hiding (Atom, nnf, T, F, Not, And, Or, Imp, Iff) 36 | import Data.Logic.ATP.PropExamples hiding (K) 37 | import Data.Logic.ATP.DefCNF 38 | import Data.Logic.ATP.DP 39 | import Data.Logic.ATP.Term 40 | import Data.Logic.ATP.Apply 41 | import Data.Logic.ATP.Equate 42 | import Data.Logic.ATP.Quantified 43 | import Data.Logic.ATP.Parser 44 | import Data.Logic.ATP.FOL 45 | import Data.Logic.ATP.Skolem 46 | import Data.Logic.ATP.Herbrand 47 | import Data.Logic.ATP.Unif 48 | import Data.Logic.ATP.Tableaux hiding (K) 49 | import Data.Logic.ATP.Resolution 50 | import Data.Logic.ATP.Prolog 51 | import Data.Logic.ATP.Meson 52 | import Data.Logic.ATP.Equal 53 | import Test.HUnit 54 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/Apply.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | {-# LANGUAGE TypeSynonymInstances #-} 13 | 14 | module Data.Logic.ATP.Apply 15 | ( IsPredicate 16 | , HasApply(TermOf, PredOf, applyPredicate, foldApply', overterms, onterms) 17 | , atomFuncs 18 | , functions 19 | , JustApply 20 | , foldApply 21 | , prettyApply 22 | , overtermsApply 23 | , ontermsApply 24 | , zipApplys 25 | , showApply 26 | , convertApply 27 | , onformula 28 | , pApp 29 | , FOLAP(AP) 30 | , Predicate 31 | , ApAtom 32 | ) where 33 | 34 | import Data.Data (Data) 35 | import Data.Logic.ATP.Formulas (IsAtom, IsFormula(..), onatoms) 36 | import Data.Logic.ATP.Pretty as Pretty ((<>), Associativity(InfixN), Doc, HasFixity(associativity, precedence), pAppPrec, text) 37 | import Data.Logic.ATP.Term (Arity, FTerm, IsTerm(FunOf, TVarOf), funcs) 38 | import Data.Set as Set (Set, union) 39 | import Data.String (IsString(fromString)) 40 | import Data.Typeable (Typeable) 41 | import Prelude hiding (pred) 42 | import Text.PrettyPrint (parens, brackets, punctuate, comma, fcat, space) 43 | import Text.PrettyPrint.HughesPJClass (Pretty(pPrint)) 44 | 45 | --------------------------- 46 | -- ATOMS (Atomic Formula) AND PREDICATES -- 47 | --------------------------- 48 | 49 | -- | A predicate is the thing we apply to a list of 'IsTerm's to make 50 | -- an 'IsAtom'. 51 | class (Eq predicate, Ord predicate, Show predicate, IsString predicate, Pretty predicate) => IsPredicate predicate 52 | 53 | -- | The result of applying a predicate to some terms is an atomic 54 | -- formula whose type is an instance of 'HasApply'. 55 | class (IsAtom atom, IsPredicate (PredOf atom), IsTerm (TermOf atom)) => HasApply atom where 56 | type PredOf atom 57 | type TermOf atom 58 | applyPredicate :: PredOf atom -> [(TermOf atom)] -> atom 59 | foldApply' :: (atom -> r) -> (PredOf atom -> [TermOf atom] -> r) -> atom -> r 60 | overterms :: (TermOf atom -> r -> r) -> r -> atom -> r 61 | onterms :: (TermOf atom -> TermOf atom) -> atom -> atom 62 | 63 | -- | The set of functions in an atom. 64 | atomFuncs :: (HasApply atom, function ~ FunOf (TermOf atom)) => atom -> Set (function, Arity) 65 | atomFuncs = overterms (Set.union . funcs) mempty 66 | 67 | -- | The set of functions in a formula. 68 | functions :: (IsFormula formula, HasApply atom, Ord function, 69 | atom ~ AtomOf formula, 70 | term ~ TermOf atom, 71 | function ~ FunOf term) => 72 | formula -> Set (function, Arity) 73 | functions fm = overatoms (Set.union . atomFuncs) fm mempty 74 | 75 | -- | Atoms that have apply but do not support equate 76 | class HasApply atom => JustApply atom 77 | 78 | foldApply :: (JustApply atom, term ~ TermOf atom) => (PredOf atom -> [term] -> r) -> atom -> r 79 | foldApply = foldApply' (error "JustApply failure") 80 | 81 | -- | Pretty print prefix application of a predicate 82 | prettyApply :: (v ~ TVarOf term, IsPredicate predicate, IsTerm term) => predicate -> [term] -> Doc 83 | prettyApply p ts = pPrint p <> parens (fcat (punctuate comma (map pPrint ts))) 84 | 85 | -- | Implementation of 'overterms' for 'HasApply' types. 86 | overtermsApply :: JustApply atom => ((TermOf atom) -> r -> r) -> r -> atom -> r 87 | overtermsApply f r0 = foldApply (\_ ts -> foldr f r0 ts) 88 | 89 | -- | Implementation of 'onterms' for 'HasApply' types. 90 | ontermsApply :: JustApply atom => ((TermOf atom) -> (TermOf atom)) -> atom -> atom 91 | ontermsApply f = foldApply (\p ts -> applyPredicate p (map f ts)) 92 | 93 | -- | Zip two atoms if they are similar 94 | zipApplys :: (JustApply atom1, term ~ TermOf atom1, predicate ~ PredOf atom1, 95 | JustApply atom2, term ~ TermOf atom2, predicate ~ PredOf atom2) => 96 | (predicate -> [(term, term)] -> Maybe r) -> atom1 -> atom2 -> Maybe r 97 | zipApplys f atom1 atom2 = 98 | foldApply f' atom1 99 | where 100 | f' p1 ts1 = foldApply (\p2 ts2 -> 101 | if p1 /= p2 || length ts1 /= length ts2 102 | then Nothing 103 | else f p1 (zip ts1 ts2)) atom2 104 | 105 | -- | Implementation of 'Show' for 'JustApply' types 106 | showApply :: (Show predicate, Show term) => predicate -> [term] -> String 107 | showApply p ts = show (text "pApp " <> parens (text (show p)) <> brackets (fcat (punctuate (comma <> space) (map (text . show) ts)))) 108 | 109 | -- | Convert between two instances of 'HasApply' 110 | convertApply :: (JustApply atom1, HasApply atom2) => 111 | (PredOf atom1 -> PredOf atom2) -> (TermOf atom1 -> TermOf atom2) -> atom1 -> atom2 112 | convertApply cp ct = foldApply (\p1 ts1 -> applyPredicate (cp p1) (map ct ts1)) 113 | 114 | -- | Special case of applying a subfunction to the top *terms*. 115 | onformula :: (IsFormula formula, HasApply atom, atom ~ AtomOf formula, term ~ TermOf atom) => 116 | (term -> term) -> formula -> formula 117 | onformula f = onatoms (onterms f) 118 | 119 | -- | Build a formula from a predicate and a list of terms. 120 | pApp :: (IsFormula formula, HasApply atom, atom ~ AtomOf formula) => PredOf atom -> [TermOf atom] -> formula 121 | pApp p args = atomic (applyPredicate p args) 122 | 123 | -- | First order logic formula atom type. 124 | data FOLAP predicate term = AP predicate [term] deriving (Eq, Ord, Data, Typeable, Read) 125 | 126 | instance (IsPredicate predicate, IsTerm term) => JustApply (FOLAP predicate term) 127 | 128 | instance (IsPredicate predicate, IsTerm term) => IsAtom (FOLAP predicate term) 129 | 130 | instance (IsPredicate predicate, IsTerm term) => Pretty (FOLAP predicate term) where 131 | pPrint = foldApply prettyApply 132 | 133 | instance (IsPredicate predicate, IsTerm term) => HasApply (FOLAP predicate term) where 134 | type PredOf (FOLAP predicate term) = predicate 135 | type TermOf (FOLAP predicate term) = term 136 | applyPredicate = AP 137 | foldApply' _ f (AP p ts) = f p ts 138 | overterms f r (AP _ ts) = foldr f r ts 139 | onterms f (AP p ts) = AP p (map f ts) 140 | 141 | instance (IsPredicate predicate, IsTerm term, Show predicate, Show term) => Show (FOLAP predicate term) where 142 | show = foldApply (\p ts -> showApply (p :: predicate) (ts :: [term])) 143 | 144 | instance HasFixity (FOLAP predicate term) where 145 | precedence _ = pAppPrec 146 | associativity _ = Pretty.InfixN 147 | 148 | -- | A predicate type with no distinct equality. 149 | data Predicate = NamedPred String 150 | deriving (Eq, Ord, Data, Typeable, Read) 151 | 152 | instance IsString Predicate where 153 | 154 | -- fromString "True" = error "bad predicate name: True" 155 | -- fromString "False" = error "bad predicate name: True" 156 | -- fromString "=" = error "bad predicate name: True" 157 | fromString s = NamedPred s 158 | 159 | instance Show Predicate where 160 | show (NamedPred s) = "fromString " ++ show s 161 | 162 | instance Pretty Predicate where 163 | pPrint (NamedPred "=") = error "Use of = as a predicate name is prohibited" 164 | pPrint (NamedPred "True") = error "Use of True as a predicate name is prohibited" 165 | pPrint (NamedPred "False") = error "Use of False as a predicate name is prohibited" 166 | pPrint (NamedPred s) = text s 167 | 168 | instance IsPredicate Predicate 169 | 170 | -- | An atom type with no equality predicate 171 | type ApAtom = FOLAP Predicate FTerm 172 | instance JustApply ApAtom 173 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/DP.hs: -------------------------------------------------------------------------------- 1 | -- | The Davis-Putnam and Davis-Putnam-Loveland-Logemann procedures. 2 | -- 3 | -- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) 4 | 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | module Data.Logic.ATP.DP 11 | ( dp, dpsat, dptaut 12 | , dpli, dplisat, dplitaut 13 | , dpll, dpllsat, dplltaut 14 | , dplb, dplbsat, dplbtaut 15 | , testDP 16 | ) where 17 | 18 | import Data.Logic.ATP.DefCNF (NumAtom(ai, ma), defcnfs) 19 | import Data.Logic.ATP.Formulas (IsFormula(AtomOf)) 20 | import Data.Logic.ATP.Lib (Failing(Success, Failure), failing, allpairs, minimize, maximize, defined, (|->), setmapfilter, flatten) 21 | import Data.Logic.ATP.Lit (IsLiteral, (.~.), negative, positive, negate, negated) 22 | import Data.Logic.ATP.Prop (trivial, JustPropositional, PFormula) 23 | import Data.Logic.ATP.PropExamples (Knows(K), prime) 24 | import Data.Map.Strict as Map (empty, Map) 25 | import Data.Set as Set (delete, difference, empty, filter, findMin, fold, insert, intersection, map, member, 26 | minView, null, partition, Set, singleton, size, union) 27 | import Prelude hiding (negate, pure) 28 | import Test.HUnit 29 | 30 | instance NumAtom (Knows Integer) where 31 | ma n = K "p" n Nothing 32 | ai (K _ n _) = n 33 | 34 | -- | The DP procedure. 35 | dp :: (IsLiteral lit, Ord lit) => Set (Set lit) -> Bool 36 | dp clauses 37 | | Set.null clauses = True 38 | | Set.member Set.empty clauses = False 39 | | otherwise = try1 40 | where 41 | try1 :: Bool 42 | try1 = failing (const try2) dp (one_literal_rule clauses) 43 | try2 :: Bool 44 | try2 = failing (const try3) dp (affirmative_negative_rule clauses) 45 | try3 :: Bool 46 | try3 = dp (resolution_rule clauses) 47 | 48 | one_literal_rule :: (IsLiteral lit, Ord lit) => Set (Set lit) -> Failing (Set (Set lit)) 49 | one_literal_rule clauses = 50 | case Set.minView (Set.filter (\ cl -> Set.size cl == 1) clauses) of 51 | Nothing -> Failure ["one_literal_rule"] 52 | Just (s, _) -> 53 | let u = Set.findMin s in 54 | let u' = (.~.) u in 55 | let clauses1 = Set.filter (\ cl -> not (Set.member u cl)) clauses in 56 | Success (Set.map (\ cl -> Set.delete u' cl) clauses1) 57 | 58 | affirmative_negative_rule :: (IsLiteral lit, Ord lit) => Set (Set lit) -> Failing (Set (Set lit)) 59 | affirmative_negative_rule clauses = 60 | let (neg',pos) = Set.partition negative (flatten clauses) in 61 | let neg = Set.map (.~.) neg' in 62 | let pos_only = Set.difference pos neg 63 | neg_only = Set.difference neg pos in 64 | let pure = Set.union pos_only (Set.map (.~.) neg_only) in 65 | if Set.null pure 66 | then Failure ["affirmative_negative_rule"] 67 | else Success (Set.filter (\ cl -> Set.null (Set.intersection cl pure)) clauses) 68 | 69 | resolve_on :: (IsLiteral lit, Ord lit) => lit -> Set (Set lit) -> Set (Set lit) 70 | resolve_on p clauses = 71 | let p' = (.~.) p 72 | (pos,notpos) = Set.partition (Set.member p) clauses in 73 | let (neg,other) = Set.partition (Set.member p') notpos in 74 | let pos' = Set.map (Set.filter (\ l -> l /= p)) pos 75 | neg' = Set.map (Set.filter (\ l -> l /= p')) neg in 76 | let res0 = allpairs Set.union pos' neg' in 77 | Set.union other (Set.filter (not . trivial) res0) 78 | 79 | resolution_blowup :: (IsLiteral lit, Ord lit) => Set (Set lit) -> lit -> Int 80 | resolution_blowup cls l = 81 | let m = Set.size (Set.filter (Set.member l) cls) 82 | n = Set.size (Set.filter (Set.member ((.~.) l)) cls) in 83 | m * n - m - n 84 | 85 | resolution_rule :: (IsLiteral lit, Ord lit) => Set (Set lit) -> Set (Set lit) 86 | resolution_rule clauses = resolve_on p clauses 87 | where 88 | pvs = Set.filter positive (flatten clauses) 89 | Just p = minimize (resolution_blowup clauses) pvs 90 | 91 | -- | Davis-Putnam satisfiability tester. 92 | dpsat :: (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Bool 93 | dpsat = dp . defcnfs 94 | 95 | -- | Davis-Putnam tautology checker. 96 | dptaut :: (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Bool 97 | dptaut = not . dpsat . negate 98 | 99 | -- Examples. 100 | 101 | test01 :: Test 102 | test01 = TestCase (assertEqual "dptaut(prime 11) p. 84" True (dptaut (prime 11 :: PFormula (Knows Integer)))) 103 | 104 | -- | The same thing but with the DPLL procedure. (p. 84) 105 | dpll :: (IsLiteral lit, Ord lit) => Set (Set lit) -> Bool 106 | dpll clauses 107 | | Set.null clauses = True 108 | | Set.member Set.empty clauses = False 109 | | otherwise = try1 110 | where 111 | try1 = failing (const try2) dpll (one_literal_rule clauses) 112 | try2 = failing (const try3) dpll (affirmative_negative_rule clauses) 113 | try3 = dpll (Set.insert (Set.singleton p) clauses) || dpll (Set.insert (Set.singleton (negate p)) clauses) 114 | Just p = maximize (posneg_count clauses) pvs 115 | pvs = Set.filter positive (flatten clauses) 116 | {- 117 | | failing (const try3) 118 | | otherwise = 119 | case one_literal_rule clauses >>= dpll of 120 | Success x -> Success x 121 | Failure _ -> 122 | case affirmative_negative_rule clauses >>= dpll of 123 | Success x -> Success x 124 | Failure _ -> 125 | let pvs = Set.filter positive (flatten clauses) in 126 | case maximize (posneg_count clauses) pvs of 127 | Nothing -> Failure ["dpll"] 128 | Just p -> 129 | case (dpll (Set.insert (Set.singleton p) clauses), dpll (Set.insert (Set.singleton (negate p)) clauses)) of 130 | (Success a, Success b) -> Success (a || b) 131 | (Failure a, Failure b) -> Failure (a ++ b) 132 | (Failure a, _) -> Failure a 133 | (_, Failure b) -> Failure b 134 | -} 135 | 136 | posneg_count :: (IsLiteral formula, Ord formula) => Set (Set formula) -> formula -> Int 137 | posneg_count cls l = 138 | let m = Set.size(Set.filter (Set.member l) cls) 139 | n = Set.size(Set.filter (Set.member (negate l)) cls) in 140 | m + n 141 | 142 | dpllsat :: (JustPropositional pf, Ord pf, AtomOf pf ~ Knows Integer) => pf -> Bool 143 | dpllsat = dpll . defcnfs 144 | 145 | dplltaut :: (JustPropositional pf, Ord pf, AtomOf pf ~ Knows Integer) => pf -> Bool 146 | dplltaut = not . dpllsat . negate 147 | 148 | -- Example. 149 | test02 :: Test 150 | test02 = TestCase (assertEqual "dplltaut(prime 11)" True (dplltaut (prime 11 :: PFormula (Knows Integer)))) 151 | 152 | -- | Iterative implementation with explicit trail instead of recursion. 153 | dpli :: (IsLiteral formula, Ord formula) => Set (formula, TrailMix) -> Set (Set formula) -> Bool 154 | dpli trail cls = 155 | let (cls', trail') = unit_propagate (cls, trail) in 156 | if Set.member Set.empty cls' then 157 | case Set.minView trail of 158 | Just ((p,Guessed), tt) -> dpli (Set.insert (negate p, Deduced) tt) cls 159 | _ -> False 160 | else 161 | case unassigned cls (trail' {-:: Set (pf, TrailMix)-}) of 162 | s | Set.null s -> True 163 | ps -> let Just p = maximize (posneg_count cls') ps in 164 | dpli (Set.insert (p {-:: pf-}, Guessed) trail') cls 165 | 166 | data TrailMix = Guessed | Deduced deriving (Eq, Ord) 167 | 168 | unassigned :: (IsLiteral formula, Ord formula, Eq formula) => Set (Set formula) -> Set (formula, TrailMix) -> Set formula 169 | unassigned cls trail = 170 | Set.difference (flatten (Set.map (Set.map litabs) cls)) (Set.map (litabs . fst) trail) 171 | where litabs p = if negated p then negate p else p 172 | 173 | unit_subpropagate :: (IsLiteral formula, Ord formula) => 174 | (Set (Set formula), Map formula (), Set (formula, TrailMix)) 175 | -> (Set (Set formula), Map formula (), Set (formula, TrailMix)) 176 | unit_subpropagate (cls,fn,trail) = 177 | let cls' = Set.map (Set.filter (not . defined fn . negate)) cls in 178 | let uu cs = 179 | case Set.minView cs of 180 | Nothing -> Failure ["unit_subpropagate"] 181 | Just (c, _) -> if Set.size cs == 1 && not (defined fn c) 182 | then Success cs 183 | else Failure ["unit_subpropagate"] in 184 | let newunits = flatten (setmapfilter uu cls') in 185 | if Set.null newunits then (cls',fn,trail) else 186 | let trail' = Set.fold (\ p t -> Set.insert (p,Deduced) t) trail newunits 187 | fn' = Set.fold (\ u -> (u |-> ())) fn newunits in 188 | unit_subpropagate (cls',fn',trail') 189 | 190 | unit_propagate :: forall t. (IsLiteral t, Ord t) => 191 | (Set (Set t), Set (t, TrailMix)) 192 | -> (Set (Set t), Set (t, TrailMix)) 193 | unit_propagate (cls,trail) = 194 | let fn = Set.fold (\ (x,_) -> (x |-> ())) Map.empty trail in 195 | let (cls',_fn',trail') = unit_subpropagate (cls,fn,trail) in (cls',trail') 196 | 197 | backtrack :: forall t. Set (t, TrailMix) -> Set (t, TrailMix) 198 | backtrack trail = 199 | case Set.minView trail of 200 | Just ((_p,Deduced), tt) -> backtrack tt 201 | _ -> trail 202 | 203 | dplisat :: (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Bool 204 | dplisat = dpli Set.empty . defcnfs 205 | 206 | dplitaut :: (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Bool 207 | dplitaut = not . dplisat . negate 208 | 209 | -- | With simple non-chronological backjumping and learning. 210 | dplb :: (IsLiteral formula, Ord formula) => Set (formula, TrailMix) -> Set (Set formula) -> Bool 211 | dplb trail cls = 212 | let (cls',trail') = unit_propagate (cls,trail) in 213 | if Set.member Set.empty cls' then 214 | case Set.minView (backtrack trail) of 215 | Just ((p,Guessed), tt) -> 216 | let trail'' = backjump cls p tt in 217 | let declits = Set.filter (\ (_,d) -> d == Guessed) trail'' in 218 | let conflict = Set.insert (negate p) (Set.map (negate . fst) declits) in 219 | dplb (Set.insert (negate p, Deduced) trail'') (Set.insert conflict cls) 220 | _ -> False 221 | else 222 | case unassigned cls trail' of 223 | s | Set.null s -> True 224 | ps -> let Just p = maximize (posneg_count cls') ps in 225 | dplb (Set.insert (p,Guessed) trail') cls 226 | 227 | backjump :: (IsLiteral a, Ord a) => Set (Set a) -> a -> Set (a, TrailMix) -> Set (a, TrailMix) 228 | backjump cls p trail = 229 | case Set.minView (backtrack trail) of 230 | Just ((_q,Guessed), tt) -> 231 | let (cls',_trail') = unit_propagate (cls, Set.insert (p,Guessed) tt) in 232 | if Set.member Set.empty cls' then backjump cls p tt else trail 233 | _ -> trail 234 | 235 | dplbsat :: (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Bool 236 | dplbsat = dplb Set.empty . defcnfs 237 | 238 | dplbtaut :: (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Bool 239 | dplbtaut = not . dplbsat . negate 240 | 241 | -- | Examples. 242 | test03 :: Test 243 | test03 = TestList [TestCase (assertEqual "dplitaut(prime 101)" True (dplitaut (prime 101 :: PFormula (Knows Integer)))), 244 | TestCase (assertEqual "dplbtaut(prime 101)" True (dplbtaut (prime 101 :: PFormula (Knows Integer))))] 245 | 246 | testDP :: Test 247 | testDP = TestLabel "DP" (TestList [test01, test02, test03]) 248 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/DefCNF.hs: -------------------------------------------------------------------------------- 1 | -- | Definitional CNF. 2 | -- 3 | -- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) 4 | 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module Data.Logic.ATP.DefCNF 13 | ( NumAtom(ma, ai) 14 | , defcnfs 15 | , defcnf1 16 | , defcnf2 17 | , defcnf3 18 | -- * Instance 19 | , Atom(N) 20 | -- * Tests 21 | , testDefCNF 22 | ) where 23 | 24 | import Data.Function (on) 25 | import Data.List as List 26 | import Data.Logic.ATP.Formulas as P 27 | import Data.Logic.ATP.Lit ((.~.), (¬), convertLiteral, IsLiteral, JustLiteral, LFormula) 28 | import Data.Logic.ATP.Pretty (assertEqual', HasFixity, Pretty(pPrint), prettyShow, text) 29 | import Data.Logic.ATP.Prop (cnf', foldPropositional, IsPropositional(foldPropositional'), JustPropositional, 30 | list_conj, list_disj, nenf, PFormula, Prop(P), simpcnf, 31 | (∨), (∧), (.<=>.), (.&.), (.|.), BinOp(..)) 32 | import Data.Map.Strict as Map hiding (fromList) 33 | import Data.Set as Set 34 | import Test.HUnit 35 | 36 | -- | Example (p. 74) 37 | test01 :: Test 38 | test01 = 39 | let p :: PFormula Prop 40 | q :: PFormula Prop 41 | r :: PFormula Prop 42 | [p, q, r] = (List.map (atomic . P) ["p", "q", "r"]) in 43 | TestCase $ assertEqual' "cnf test (p. 74)" 44 | ((p∨q∨r)∧(p∨(¬)q∨(¬)r)∧(q∨(¬)p∨(¬)r)∧(r∨(¬)p∨(¬)q)) 45 | (cnf' (p .<=>. (q .<=>. r)) :: PFormula Prop) 46 | 47 | class NumAtom atom where 48 | ma :: Integer -> atom 49 | ai :: atom -> Integer 50 | 51 | data Atom = N String Integer deriving (Eq, Ord, Show) 52 | 53 | instance Pretty Atom where 54 | pPrint (N s n) = text (s ++ if n == 0 then "" else show n) 55 | 56 | instance NumAtom Atom where 57 | ma = N "p_" 58 | ai (N _ n) = n 59 | 60 | instance HasFixity Atom 61 | 62 | instance IsAtom Atom 63 | 64 | -- | Make a stylized variable and update the index. 65 | mkprop :: forall pf. (IsPropositional pf, NumAtom (AtomOf pf)) => Integer -> (pf, Integer) 66 | mkprop n = (atomic (ma n :: AtomOf pf), n + 1) 67 | 68 | -- | Core definitional CNF procedure. 69 | maincnf :: (IsPropositional pf, Ord pf, NumAtom (AtomOf pf)) => (pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer) 70 | maincnf trip@(fm, _defs, _n) = 71 | foldPropositional' ho co ne tf at fm 72 | where 73 | ho _ = trip 74 | co p (:&:) q = defstep (.&.) (p,q) trip 75 | co p (:|:) q = defstep (.|.) (p,q) trip 76 | co p (:<=>:) q = defstep (.<=>.) (p,q) trip 77 | co _ (:=>:) _ = trip 78 | ne _ = trip 79 | tf _ = trip 80 | at _ = trip 81 | 82 | defstep :: (IsPropositional pf, NumAtom (AtomOf pf), Ord pf) => 83 | (pf -> pf -> pf) -> (pf, pf) -> (pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer) 84 | defstep op (p,q) (_fm, defs, n) = 85 | let (fm1,defs1,n1) = maincnf (p,defs,n) in 86 | let (fm2,defs2,n2) = maincnf (q,defs1,n1) in 87 | let fm' = op fm1 fm2 in 88 | case Map.lookup fm' defs2 of 89 | Just _ -> (fm', defs2, n2) 90 | Nothing -> let (v,n3) = mkprop n2 in (v, Map.insert v (v .<=>. fm') defs2,n3) 91 | 92 | -- | Make n large enough that "v_m" won't clash with s for any m >= n 93 | max_varindex :: NumAtom atom => atom -> Integer -> Integer 94 | max_varindex atom n = max n (ai atom) 95 | 96 | -- | Overall definitional CNF. 97 | defcnf1 :: forall pf. (IsPropositional pf, JustPropositional pf, NumAtom (AtomOf pf), Ord pf) => pf -> pf 98 | defcnf1 = list_conj . Set.map (list_disj . Set.map (convertLiteral id)) . (mk_defcnf id maincnf :: pf -> Set (Set (LFormula (AtomOf pf)))) 99 | 100 | mk_defcnf :: forall pf lit. 101 | (IsPropositional pf, JustPropositional pf, 102 | IsLiteral lit, JustLiteral lit, Ord lit, 103 | NumAtom (AtomOf pf)) => 104 | (AtomOf pf -> AtomOf lit) 105 | -> ((pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer)) 106 | -> pf -> Set (Set lit) 107 | mk_defcnf ca fn fm = 108 | let (fm' :: pf) = nenf fm in 109 | let n = 1 + overatoms max_varindex fm' 0 in 110 | let (fm'',defs,_) = fn (fm',Map.empty,n) in 111 | let (deflist :: [pf]) = Map.elems defs in 112 | Set.unions (List.map (simpcnf ca :: pf -> Set (Set lit)) (fm'' : deflist)) 113 | 114 | testfm :: PFormula Atom 115 | testfm = let (p, q, r, s) = (atomic (N "p" 0), atomic (N "q" 0), atomic (N "r" 0), atomic (N "s" 0)) in 116 | (p .|. (q .&. ((.~.) r))) .&. s 117 | 118 | -- Example. 119 | {- 120 | START_INTERACTIVE;; 121 | defcnf1 <<(p \/ (q /\ ~r)) /\ s>>;; 122 | END_INTERACTIVE;; 123 | -} 124 | 125 | test02 :: Test 126 | test02 = 127 | let input = strings (mk_defcnf id maincnf testfm :: Set (Set (LFormula Atom))) 128 | expected = [["p_3"], 129 | ["p_2","¬p"], 130 | ["p_2","¬p_1"], 131 | ["p_2","¬p_3"], 132 | ["q","¬p_1"], 133 | ["s","¬p_3"], 134 | ["¬p_1","¬r"], 135 | ["p","p_1","¬p_2"], 136 | ["p_1","r","¬q"], 137 | ["p_3","¬p_2","¬s"]] in 138 | TestCase $ assertEqual "defcnf1 (p. 77)" expected input 139 | 140 | strings :: Pretty a => Set (Set a) -> [[String]] 141 | strings ss = sortBy (compare `on` length) . sort . Set.toList $ Set.map (sort . Set.toList . Set.map prettyShow) ss 142 | 143 | -- | Version tweaked to exploit initial structure. 144 | defcnf2 :: (IsPropositional pf, JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> pf 145 | defcnf2 fm = list_conj (Set.map (list_disj . Set.map (convertLiteral id)) (defcnfs fm)) 146 | 147 | defcnfs :: (IsPropositional pf, JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> Set (Set (LFormula (AtomOf pf))) 148 | defcnfs fm = mk_defcnf id andcnf fm 149 | 150 | andcnf :: (IsPropositional pf, JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => (pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer) 151 | andcnf trip@(fm,_defs,_n) = 152 | foldPropositional co (\ _ -> orcnf trip) (\ _ -> orcnf trip) (\ _ -> orcnf trip) fm 153 | where 154 | co p (:&:) q = subcnf andcnf (.&.) p q trip 155 | co _ _ _ = orcnf trip 156 | 157 | orcnf :: (IsPropositional pf, JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => (pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer) 158 | orcnf trip@(fm,_defs,_n) = 159 | foldPropositional co (\ _ -> maincnf trip) (\ _ -> maincnf trip) (\ _ -> maincnf trip) fm 160 | where 161 | co p (:|:) q = subcnf orcnf (.|.) p q trip 162 | co _ _ _ = maincnf trip 163 | 164 | subcnf :: (IsPropositional pf, NumAtom (AtomOf pf)) => 165 | ((pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer)) 166 | -> (pf -> pf -> pf) 167 | -> pf 168 | -> pf 169 | -> (pf, Map pf pf, Integer) 170 | -> (pf, Map pf pf, Integer) 171 | subcnf sfn op p q (_fm,defs,n) = 172 | let (fm1,defs1,n1) = sfn (p,defs,n) in 173 | let (fm2,defs2,n2) = sfn (q,defs1,n1) in 174 | (op fm1 fm2, defs2, n2) 175 | 176 | -- | Version that guarantees 3-CNF. 177 | defcnf3 :: forall pf. (JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => pf -> pf 178 | defcnf3 = list_conj . Set.map (list_disj . Set.map (convertLiteral id)) . (mk_defcnf id andcnf3 :: pf -> Set (Set (LFormula (AtomOf pf)))) 179 | 180 | andcnf3 :: (IsPropositional pf, JustPropositional pf, Ord pf, NumAtom (AtomOf pf)) => (pf, Map pf pf, Integer) -> (pf, Map pf pf, Integer) 181 | andcnf3 trip@(fm,_defs,_n) = 182 | foldPropositional co (\ _ -> maincnf trip) (\ _ -> maincnf trip) (\ _ -> maincnf trip) fm 183 | where 184 | co p (:&:) q = subcnf andcnf3 (.&.) p q trip 185 | co _ _ _ = maincnf trip 186 | 187 | test03 :: Test 188 | test03 = 189 | let input = strings (mk_defcnf id andcnf3 testfm :: Set (Set (LFormula Atom))) 190 | expected = [["p_2"], 191 | ["s"], 192 | ["p_2","¬p"], 193 | ["p_2","¬p_1"], 194 | ["q","¬p_1"], 195 | ["¬p_1","¬r"], 196 | ["p","p_1","¬p_2"], 197 | ["p_1","r","¬q"]] in 198 | TestCase $ assertEqual "defcnf1 (p. 77)" expected input 199 | 200 | testDefCNF :: Test 201 | testDefCNF = TestLabel "DefCNF" (TestList [test01, test02, test03]) 202 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/Equal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | -- | First order logic with equality. 4 | -- 5 | -- Copyright (co) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) 6 | 7 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables, TypeSynonymInstances #-} 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | module Data.Logic.ATP.Equal 11 | ( function_congruence 12 | , equalitize 13 | -- * Tests 14 | , wishnu 15 | , testEqual 16 | ) where 17 | 18 | import Data.Logic.ATP.Apply (functions, HasApply(TermOf, PredOf, applyPredicate), pApp) 19 | import Data.Logic.ATP.Equate ((.=.), HasEquate(foldEquate)) 20 | import Data.Logic.ATP.Formulas (IsFormula(AtomOf, atomic), atom_union) 21 | import Data.Logic.ATP.Lib ((∅), Depth(Depth), Failing (Success, Failure), timeMessage) 22 | import Data.Logic.ATP.Meson (meson) 23 | import Data.Logic.ATP.Pretty (assertEqual') 24 | import Data.Logic.ATP.Prop ((.&.), (.=>.), (∧), (⇒)) 25 | import Data.Logic.ATP.Quantified ((∃), (∀), IsQuantified(..)) 26 | import Data.Logic.ATP.Parser (fof) 27 | import Data.Logic.ATP.Skolem (runSkolem, Formula) 28 | import Data.Logic.ATP.Term (IsTerm(..)) 29 | import Data.List as List (foldr, map) 30 | import Data.Set as Set 31 | import Data.String (IsString(fromString)) 32 | import Prelude hiding ((*)) 33 | import Test.HUnit 34 | 35 | -- is_eq :: (IsQuantified fof atom v, IsAtomWithEquate atom p term) => fof -> Bool 36 | -- is_eq = foldFirstOrder (\ _ _ _ -> False) (\ _ -> False) (\ _ -> False) (foldAtomEq (\ _ _ -> False) (\ _ -> False) (\ _ _ -> True)) 37 | -- 38 | -- mk_eq :: (IsQuantified fof atom v, IsAtomWithEquate atom p term) => term -> term -> fof 39 | -- mk_eq = (.=.) 40 | -- 41 | -- dest_eq :: (IsQuantified fof atom v, IsAtomWithEquate atom p term) => fof -> Failing (term, term) 42 | -- dest_eq fm = 43 | -- foldFirstOrder (\ _ _ _ -> err) (\ _ -> err) (\ _ -> err) at fm 44 | -- where 45 | -- at = foldAtomEq (\ _ _ -> err) (\ _ -> err) (\ s t -> Success (s, t)) 46 | -- err = Failure ["dest_eq: not an equation"] 47 | -- 48 | -- lhs :: (IsQuantified fof atom v, IsAtomWithEquate atom p term) => fof -> Failing term 49 | -- lhs eq = dest_eq eq >>= return . fst 50 | -- rhs :: (IsQuantified fof atom v, IsAtomWithEquate atom p term) => fof -> Failing term 51 | -- rhs eq = dest_eq eq >>= return . snd 52 | 53 | -- | The set of predicates in a formula. 54 | -- predicates :: (IsQuantified formula atom v, IsAtomWithEquate atom p term, Ord atom, Ord p) => formula -> Set atom 55 | predicates :: IsFormula formula => formula -> Set (AtomOf formula) 56 | predicates fm = atom_union Set.singleton fm 57 | 58 | -- | Code to generate equate axioms for functions. 59 | function_congruence :: forall fof atom term v p function. 60 | (atom ~ AtomOf fof, term ~ TermOf atom, p ~ PredOf atom, v ~ VarOf fof, v ~ TVarOf term, function ~ FunOf term, 61 | IsQuantified fof, HasEquate atom, IsTerm term, Ord fof) => 62 | (function, Int) -> Set fof 63 | function_congruence (_,0) = (∅) 64 | function_congruence (f,n) = 65 | Set.singleton (List.foldr (∀) (ant ⇒ con) (argnames_x ++ argnames_y)) 66 | where 67 | argnames_x :: [VarOf fof] 68 | argnames_x = List.map (\ m -> fromString ("x" ++ show m)) [1..n] 69 | argnames_y :: [VarOf fof] 70 | argnames_y = List.map (\ m -> fromString ("y" ++ show m)) [1..n] 71 | args_x = List.map vt argnames_x 72 | args_y = List.map vt argnames_y 73 | ant = foldr1 (∧) (List.map (uncurry (.=.)) (zip args_x args_y)) 74 | con = fApp f args_x .=. fApp f args_y 75 | 76 | -- | And for predicates. 77 | predicate_congruence :: (atom ~ AtomOf fof, predicate ~ PredOf atom, term ~ TermOf atom, v ~ VarOf fof, v ~ TVarOf term, 78 | IsQuantified fof, HasEquate atom, IsTerm term, Ord predicate) => 79 | AtomOf fof -> Set fof 80 | predicate_congruence = 81 | foldEquate (\_ _ -> Set.empty) (\p ts -> ap p (length ts)) 82 | where 83 | ap _ 0 = Set.empty 84 | ap p n = Set.singleton (List.foldr (∀) (ant ⇒ con) (argnames_x ++ argnames_y)) 85 | where 86 | argnames_x = List.map (\ m -> fromString ("x" ++ show m)) [1..n] 87 | argnames_y = List.map (\ m -> fromString ("y" ++ show m)) [1..n] 88 | args_x = List.map vt argnames_x 89 | args_y = List.map vt argnames_y 90 | ant = foldr1 (∧) (List.map (uncurry (.=.)) (zip args_x args_y)) 91 | con = atomic (applyPredicate p args_x) ⇒ atomic (applyPredicate p args_y) 92 | 93 | -- | Hence implement logic with equate just by adding equate "axioms". 94 | equivalence_axioms :: forall fof atom term v. 95 | (atom ~ AtomOf fof, term ~ TermOf atom, v ~ VarOf fof, 96 | IsQuantified fof, HasEquate atom, IsTerm term, Ord fof) => Set fof 97 | equivalence_axioms = 98 | Set.fromList 99 | [(∀) "x" (x .=. x), 100 | (∀) "x" ((∀) "y" ((∀) "z" (x .=. y ∧ x .=. z ⇒ y .=. z)))] 101 | where 102 | x :: term 103 | x = vt (fromString "x") 104 | y :: term 105 | y = vt (fromString "y") 106 | z :: term 107 | z = vt (fromString "z") 108 | 109 | equalitize :: forall formula atom term v function. 110 | (atom ~ AtomOf formula, term ~ TermOf atom, v ~ VarOf formula, v ~ TVarOf term, function ~ FunOf term, 111 | IsQuantified formula, HasEquate atom, 112 | IsTerm term, Ord formula, Ord atom) => 113 | formula -> formula 114 | equalitize fm = 115 | if Set.null eqPreds then fm else foldr1 (∧) axioms ⇒ fm 116 | where 117 | axioms = Set.fold (Set.union . function_congruence) 118 | (Set.fold (Set.union . predicate_congruence) equivalence_axioms otherPreds) 119 | (functions fm) 120 | (eqPreds, otherPreds) = Set.partition (foldEquate (\_ _ -> True) (\_ _ -> False)) (predicates fm) 121 | 122 | -- ------------------------------------------------------------------------- 123 | -- Example. 124 | -- ------------------------------------------------------------------------- 125 | 126 | testEqual01 :: Test 127 | testEqual01 = TestLabel "function_congruence" $ TestCase $ assertEqual "function_congruence" expected input 128 | where input = List.map function_congruence [(fromString "f", 3 :: Int), (fromString "+",2)] 129 | expected :: [Set.Set Formula] 130 | expected = [Set.fromList 131 | [(∀) "x1" 132 | ((∀) "x2" 133 | ((∀) "x3" 134 | ((∀) "y1" 135 | ((∀) "y2" 136 | ((∀) "y3" ((("x1" .=. "y1") ∧ (("x2" .=. "y2") ∧ ("x3" .=. "y3"))) ⇒ 137 | ((fApp (fromString "f") ["x1","x2","x3"]) .=. (fApp (fromString "f") ["y1","y2","y3"]))))))))], 138 | Set.fromList 139 | [(∀) "x1" 140 | ((∀) "x2" 141 | ((∀) "y1" 142 | ((∀) "y2" ((("x1" .=. "y1") ∧ ("x2" .=. "y2")) ⇒ 143 | ((fApp (fromString "+") ["x1","x2"]) .=. (fApp (fromString "+") ["y1","y2"]))))))]] 144 | 145 | -- ------------------------------------------------------------------------- 146 | -- A simple example (see EWD1266a and the application to Morley's theorem). 147 | -- ------------------------------------------------------------------------- 148 | 149 | ewd :: Formula 150 | ewd = equalitize fm 151 | where 152 | fm = ((∀) "x" (fx ⇒ gx)) ∧ 153 | ((∃) "x" fx) ∧ 154 | ((∀) "x" ((∀) "y" (gx ∧ gy ⇒ x .=. y))) ⇒ 155 | ((∀) "y" (gy ⇒ fy)) 156 | fx = pApp "f" [x] 157 | gx = pApp "g" [x] 158 | fy = pApp "f" [y] 159 | gy = pApp "g" [y] 160 | x = vt "x" 161 | y = vt "y" 162 | 163 | testEqual02 :: Test 164 | testEqual02 = TestLabel "equalitize 1 (p. 241)" $ TestCase $ assertEqual "equalitize 1 (p. 241)" (expected, expectedProof) input 165 | where input = (ewd, runSkolem (meson (Just (Depth 17)) ewd)) 166 | fx = pApp "f" [x] 167 | gx = pApp "g" [x] 168 | fy = pApp "f" [y] 169 | gy = pApp "g" [y] 170 | x = vt "x" 171 | y = vt "y" 172 | z = vt "z" 173 | x1 = vt "x1" 174 | y1 = vt "y1" 175 | fx1 = pApp "f" [x1] 176 | gx1 = pApp "g" [x1] 177 | fy1 = pApp "f" [y1] 178 | gy1 = pApp "g" [y1] 179 | -- y1 = fromString "y1" 180 | -- z = fromString "z" 181 | expected = 182 | ((∀) "x" (x .=. x) .&. 183 | (((∀) "x" ((∀) "y" ((∀) "z" (x .=. y .&. x .=. z .=>. y .=. z)))) .&. 184 | (((∀) "x1" ((∀) "y1" (x1 .=. y1 .=>. fx1 .=>. fy1))) .&. 185 | ((∀) "x1" ((∀) "y1" (x1 .=. y1 .=>. gx1 .=>. gy1)))))) .=>. 186 | ((∀) "x" (fx .=>. gx)) .&. 187 | ((∃) "x" (fx)) .&. 188 | ((∀) "x" ((∀) "y" (gx .&. gy .=>. x .=. y))) .=>. 189 | ((∀) "y" (gy .=>. fy)) 190 | expectedProof = 191 | Set.fromList [Success (Depth 6)] 192 | 193 | -- | Wishnu Prasetya's example (even nicer with an "exists unique" primitive). 194 | 195 | --instance IsString ([MyTerm] -> MyTerm) where 196 | -- fromString = fApp . fromString 197 | 198 | wishnu :: Formula 199 | 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')) |] 200 | 201 | -- This takes 0.7 seconds on my machine. 202 | testEqual03 :: Test 203 | testEqual03 = 204 | (TestLabel "equalitize 2" . TestCase . timeMessage (\_ t -> "\nEqualitize 2 compute time: " ++ show t)) 205 | (assertEqual' "equalitize 2 (p. 241)" (expected, expectedProof) input) 206 | where input = (equalitize wishnu, runSkolem (meson Nothing (equalitize wishnu))) 207 | expected :: Formula 208 | expected = [fof| (∀x. x=x)∧ 209 | (∀x y z. x=y∧x=z⇒y=z)∧ 210 | (∀x1 y1. x1=y1⇒f(x1)=f(y1))∧ 211 | (∀x1 y1. x1=y1⇒g(x1)=g(y1))⇒ 212 | ((∃x. x=f(g(x))∧(∀x'. x'=f(g(x'))⇒x=x'))⇔ 213 | (∃y. y=g(f(y))∧(∀y'. y'=g(f(y'))⇒y=y'))) |] 214 | expectedProof = Set.fromList [Success (Depth 16)] 215 | 216 | -- ------------------------------------------------------------------------- 217 | -- More challenging equational problems. (Size 18, 61814 seconds.) 218 | -- ------------------------------------------------------------------------- 219 | 220 | {- 221 | (meson ** equalitize) 222 | <<(forall x y z. x * (y * z) = (x * y) * z) /\ 223 | (forall x. 1 * x = x) /\ 224 | (forall x. i(x) * x = 1) 225 | ==> forall x. x * i(x) = 1>>;; 226 | -} 227 | 228 | testEqual04 :: Test 229 | testEqual04 = TestLabel "equalitize 3 (p. 248)" $ TestCase $ 230 | timeMessage (\_ t -> "\nCompute time: " ++ show t) $ 231 | assertEqual' "equalitize 3 (p. 248)" (expected, expectedProof) input 232 | where 233 | input = (equalitize fm, runSkolem (meson (Just (Depth 20)) . equalitize $ fm)) 234 | fm :: Formula 235 | fm = [fof| (forall x y z. x * (y * z) = (x * y) * z) .&. 236 | (forall x. 1 * x = x) .&. 237 | (forall x. i(x) * x = 1) 238 | ==> (forall x. x * i(x) = 1) |] 239 | {- 240 | fm = [fof| (∀x y z. ((*) ["x'", (*) ["y'", "z'"]] .=. (*) [((*) ["x'", "y'"]), "z'"]) ∧ 241 | (∀) "x" ((*) [one, "x'"] .=. "x'") ∧ 242 | (∀) "x" ((*) [i ["x'"], "x'"] .=. one) ⇒ 243 | (∀) "x" ((*) ["x'", i ["x'"]] .=. one) 244 | fm = ((∀) "x" . (∀) "y" . (∀) "z") ((*) ["x'", (*) ["y'", "z'"]] .=. (*) [((*) ["x'", "y'"]), "z'"]) ∧ 245 | (∀) "x" ((*) [one, "x'"] .=. "x'") ∧ 246 | (∀) "x" ((*) [i ["x'"], "x'"] .=. one) ⇒ 247 | (∀) "x" ((*) ["x'", i ["x'"]] .=. one) 248 | (*) = fApp (fromString "*") 249 | i = fApp (fromString "i") 250 | one = fApp (fromString "1") [] 251 | -} 252 | expected :: Formula 253 | expected = 254 | [fof| (∀x. x=x)∧ 255 | (∀x y z. x=y∧x=z⇒y=z)∧ 256 | (∀x' x'' y' y''. x'=y'∧x''=y''⇒(x' * x'')=(y' * y''))⇒ 257 | (∀x y z. (x' * (y' * z'))=((x'* y') * z'))∧ 258 | (∀x. (1 * x')=x')∧ 259 | (∀x. (i(x') * x')=1)⇒ 260 | (∀x. (x' * i(x'))=1) |] 261 | {- 262 | ((∀) "x" ("x" .=. "x") .&. 263 | ((∀) "x" ((∀) "y" ((∀) "z" ((("x" .=. "y") .&. ("x" .=. "z")) .=>. ("y" .=. "z")))) .&. 264 | ((∀) "x1" ((∀) "x2" ((∀) "y1" ((∀) "y2" ((("x1" .=. "y1") .&. ("x2" .=. "y2")) .=>. 265 | ((fApp "*" ["x1","x2"]) .=. (fApp "*" ["y1","y2"])))))) .&. 266 | (∀) "x1" ((∀) "y1" (("x1" .=. "y1") .=>. ((fApp "i" ["x1"]) .=. (fApp "i" ["y1"]))))))) .=>. 267 | ((((∀) "x" ((∀) "y" ((∀) "z" ((fApp "*" ["x",fApp "*" ["y","z"]]) .=. (fApp "*" [fApp "*" ["x","y"],"z"])))) .&. 268 | (∀) "x" ((fApp "*" [fApp "1" [],"x"]) .=. "x")) .&. 269 | (∀) "x" ((fApp "*" [fApp "i" ["x"],"x"]) .=. (fApp "1" []))) .=>. 270 | (∀) "x" ((fApp "*" ["x",fApp "i" ["x"]]) .=. (fApp "1" []))) -} 271 | expectedProof :: Set.Set (Failing Depth) 272 | expectedProof = Set.fromList [Failure ["Exceeded maximum depth limit"]] 273 | 274 | testEqual :: Test 275 | testEqual = TestLabel "Equal" (TestList [testEqual01, testEqual02, testEqual03 {-, testEqual04-}]) 276 | 277 | -- ------------------------------------------------------------------------- 278 | -- Other variants not mentioned in book. 279 | -- ------------------------------------------------------------------------- 280 | 281 | {- 282 | {- ************ 283 | 284 | (meson ** equalitize) 285 | <<(forall x y z. x * (y * z) = (x * y) * z) /\ 286 | (forall x. 1 * x = x) /\ 287 | (forall x. x * 1 = x) /\ 288 | (forall x. x * x = 1) 289 | ==> forall x y. x * y = y * x>>;; 290 | 291 | -- ------------------------------------------------------------------------- 292 | -- With symmetry at leaves and one-sided congruences (Size = 16, 54659 s). 293 | -- ------------------------------------------------------------------------- 294 | 295 | let fm = 296 | <<(forall x. x = x) /\ 297 | (forall x y z. x * (y * z) = (x * y) * z) /\ 298 | (forall x y z. =((x * y) * z,x * (y * z))) /\ 299 | (forall x. 1 * x = x) /\ 300 | (forall x. x = 1 * x) /\ 301 | (forall x. i(x) * x = 1) /\ 302 | (forall x. 1 = i(x) * x) /\ 303 | (forall x y. x = y ==> i(x) = i(y)) /\ 304 | (forall x y z. x = y ==> x * z = y * z) /\ 305 | (forall x y z. x = y ==> z * x = z * y) /\ 306 | (forall x y z. x = y /\ y = z ==> x = z) 307 | ==> forall x. x * i(x) = 1>>;; 308 | 309 | time meson fm;; 310 | 311 | -- ------------------------------------------------------------------------- 312 | -- Newer version of stratified equalities. 313 | -- ------------------------------------------------------------------------- 314 | 315 | let fm = 316 | <<(forall x y z. axiom(x * (y * z),(x * y) * z)) /\ 317 | (forall x y z. axiom((x * y) * z,x * (y * z)) /\ 318 | (forall x. axiom(1 * x,x)) /\ 319 | (forall x. axiom(x,1 * x)) /\ 320 | (forall x. axiom(i(x) * x,1)) /\ 321 | (forall x. axiom(1,i(x) * x)) /\ 322 | (forall x x'. x = x' ==> cchain(i(x),i(x'))) /\ 323 | (forall x x' y y'. x = x' /\ y = y' ==> cchain(x * y,x' * y'))) /\ 324 | (forall s t. axiom(s,t) ==> achain(s,t)) /\ 325 | (forall s t u. axiom(s,t) /\ (t = u) ==> achain(s,u)) /\ 326 | (forall x x' u. x = x' /\ achain(i(x'),u) ==> cchain(i(x),u)) /\ 327 | (forall x x' y y' u. 328 | x = x' /\ y = y' /\ achain(x' * y',u) ==> cchain(x * y,u)) /\ 329 | (forall s t. cchain(s,t) ==> s = t) /\ 330 | (forall s t. achain(s,t) ==> s = t) /\ 331 | (forall t. t = t) 332 | ==> forall x. x * i(x) = 1>>;; 333 | 334 | time meson fm;; 335 | 336 | let fm = 337 | <<(forall x y z. axiom(x * (y * z),(x * y) * z)) /\ 338 | (forall x y z. axiom((x * y) * z,x * (y * z)) /\ 339 | (forall x. axiom(1 * x,x)) /\ 340 | (forall x. axiom(x,1 * x)) /\ 341 | (forall x. axiom(i(x) * x,1)) /\ 342 | (forall x. axiom(1,i(x) * x)) /\ 343 | (forall x x'. x = x' ==> cong(i(x),i(x'))) /\ 344 | (forall x x' y y'. x = x' /\ y = y' ==> cong(x * y,x' * y'))) /\ 345 | (forall s t. axiom(s,t) ==> achain(s,t)) /\ 346 | (forall s t. cong(s,t) ==> cchain(s,t)) /\ 347 | (forall s t u. axiom(s,t) /\ (t = u) ==> achain(s,u)) /\ 348 | (forall s t u. cong(s,t) /\ achain(t,u) ==> cchain(s,u)) /\ 349 | (forall s t. cchain(s,t) ==> s = t) /\ 350 | (forall s t. achain(s,t) ==> s = t) /\ 351 | (forall t. t = t) 352 | ==> forall x. x * i(x) = 1>>;; 353 | 354 | time meson fm;; 355 | 356 | -- ------------------------------------------------------------------------- 357 | -- Showing congruence closure. 358 | -- ------------------------------------------------------------------------- 359 | 360 | let fm = equalitize 361 | < f(c) = c>>;; 362 | 363 | time meson fm;; 364 | 365 | let fm = 366 | < achain(s,t)) /\ 371 | (forall s t. cong(s,t) ==> cchain(s,t)) /\ 372 | (forall s t u. axiom(s,t) /\ (t = u) ==> achain(s,u)) /\ 373 | (forall s t u. cong(s,t) /\ achain(t,u) ==> cchain(s,u)) /\ 374 | (forall s t. cchain(s,t) ==> s = t) /\ 375 | (forall s t. achain(s,t) ==> s = t) /\ 376 | (forall t. t = t) /\ 377 | (forall x y. x = y ==> cong(f(x),f(y))) 378 | ==> f(c) = c>>;; 379 | 380 | time meson fm;; 381 | 382 | -- ------------------------------------------------------------------------- 383 | -- With stratified equalities. 384 | -- ------------------------------------------------------------------------- 385 | 386 | let fm = 387 | <<(forall x y z. eqA (x * (y * z),(x * y) * z)) /\ 388 | (forall x y z. eqA ((x * y) * z)) /\ 389 | (forall x. eqA (1 * x,x)) /\ 390 | (forall x. eqA (x,1 * x)) /\ 391 | (forall x. eqA (i(x) * x,1)) /\ 392 | (forall x. eqA (1,i(x) * x)) /\ 393 | (forall x. eqA (x,x)) /\ 394 | (forall x y. eqA (x,y) ==> eqC (i(x),i(y))) /\ 395 | (forall x y. eqC (x,y) ==> eqC (i(x),i(y))) /\ 396 | (forall x y. eqT (x,y) ==> eqC (i(x),i(y))) /\ 397 | (forall w x y z. eqA (w,x) /\ eqA (y,z) ==> eqC (w * y,x * z)) /\ 398 | (forall w x y z. eqA (w,x) /\ eqC (y,z) ==> eqC (w * y,x * z)) /\ 399 | (forall w x y z. eqA (w,x) /\ eqT (y,z) ==> eqC (w * y,x * z)) /\ 400 | (forall w x y z. eqC (w,x) /\ eqA (y,z) ==> eqC (w * y,x * z)) /\ 401 | (forall w x y z. eqC (w,x) /\ eqC (y,z) ==> eqC (w * y,x * z)) /\ 402 | (forall w x y z. eqC (w,x) /\ eqT (y,z) ==> eqC (w * y,x * z)) /\ 403 | (forall w x y z. eqT (w,x) /\ eqA (y,z) ==> eqC (w * y,x * z)) /\ 404 | (forall w x y z. eqT (w,x) /\ eqC (y,z) ==> eqC (w * y,x * z)) /\ 405 | (forall w x y z. eqT (w,x) /\ eqT (y,z) ==> eqC (w * y,x * z)) /\ 406 | (forall x y z. eqA (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\ 407 | (forall x y z. eqC (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\ 408 | (forall x y z. eqA (x,y) /\ eqC (y,z) ==> eqT (x,z)) /\ 409 | (forall x y z. eqA (x,y) /\ eqT (y,z) ==> eqT (x,z)) /\ 410 | (forall x y z. eqC (x,y) /\ eqT (y,z) ==> eqT (x,z)) 411 | ==> forall x. eqT (x * i(x),1)>>;; 412 | 413 | -- ------------------------------------------------------------------------- 414 | -- With transitivity chains... 415 | -- ------------------------------------------------------------------------- 416 | 417 | let fm = 418 | <<(forall x y z. eqA (x * (y * z),(x * y) * z)) /\ 419 | (forall x y z. eqA ((x * y) * z)) /\ 420 | (forall x. eqA (1 * x,x)) /\ 421 | (forall x. eqA (x,1 * x)) /\ 422 | (forall x. eqA (i(x) * x,1)) /\ 423 | (forall x. eqA (1,i(x) * x)) /\ 424 | (forall x y. eqA (x,y) ==> eqC (i(x),i(y))) /\ 425 | (forall x y. eqC (x,y) ==> eqC (i(x),i(y))) /\ 426 | (forall w x y. eqA (w,x) ==> eqC (w * y,x * y)) /\ 427 | (forall w x y. eqC (w,x) ==> eqC (w * y,x * y)) /\ 428 | (forall x y z. eqA (y,z) ==> eqC (x * y,x * z)) /\ 429 | (forall x y z. eqC (y,z) ==> eqC (x * y,x * z)) /\ 430 | (forall x y z. eqA (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\ 431 | (forall x y z. eqC (x,y) /\ eqA (y,z) ==> eqT (x,z)) /\ 432 | (forall x y z. eqA (x,y) /\ eqC (y,z) ==> eqT (x,z)) /\ 433 | (forall x y z. eqC (x,y) /\ eqC (y,z) ==> eqT (x,z)) /\ 434 | (forall x y z. eqA (x,y) /\ eqT (y,z) ==> eqT (x,z)) /\ 435 | (forall x y z. eqC (x,y) /\ eqT (y,z) ==> eqT (x,z)) 436 | ==> forall x. eqT (x * i(x),1) \/ eqC (x * i(x),1)>>;; 437 | 438 | time meson fm;; 439 | 440 | -- ------------------------------------------------------------------------- 441 | -- Enforce canonicity (proof size = 20). 442 | -- ------------------------------------------------------------------------- 443 | 444 | let fm = 445 | <<(forall x y z. eq1(x * (y * z),(x * y) * z)) /\ 446 | (forall x y z. eq1((x * y) * z,x * (y * z))) /\ 447 | (forall x. eq1(1 * x,x)) /\ 448 | (forall x. eq1(x,1 * x)) /\ 449 | (forall x. eq1(i(x) * x,1)) /\ 450 | (forall x. eq1(1,i(x) * x)) /\ 451 | (forall x y z. eq1(x,y) ==> eq1(x * z,y * z)) /\ 452 | (forall x y z. eq1(x,y) ==> eq1(z * x,z * y)) /\ 453 | (forall x y z. eq1(x,y) /\ eq2(y,z) ==> eq2(x,z)) /\ 454 | (forall x y. eq1(x,y) ==> eq2(x,y)) 455 | ==> forall x. eq2(x,i(x))>>;; 456 | 457 | time meson fm;; 458 | 459 | ***************** -} 460 | END_INTERACTIVE;; 461 | -} 462 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/Equate.hs: -------------------------------------------------------------------------------- 1 | -- | ATOM with a distinguished Equate predicate. 2 | 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | module Data.Logic.ATP.Equate 16 | ( HasEquate(equate, foldEquate) 17 | , (.=.) 18 | , zipEquates 19 | , prettyEquate 20 | , overtermsEq 21 | , ontermsEq 22 | , showApplyAndEquate 23 | , showEquate 24 | , convertEquate 25 | , precedenceEquate 26 | , associativityEquate 27 | , FOL(R, Equals) 28 | , EqAtom 29 | ) where 30 | 31 | import Data.Data (Data) 32 | import Data.Logic.ATP.Apply (HasApply(PredOf, TermOf, applyPredicate, foldApply', overterms, onterms), 33 | IsPredicate, Predicate, prettyApply, showApply) 34 | import Data.Logic.ATP.Formulas (IsAtom, IsFormula(..)) 35 | import Data.Logic.ATP.Pretty as Pretty ((<>), Associativity(InfixN), atomPrec, Doc, eqPrec, HasFixity(associativity, precedence), pAppPrec, Precedence, text) 36 | import Data.Logic.ATP.Term (FTerm, IsTerm) 37 | import Data.Typeable (Typeable) 38 | import Prelude hiding (pred) 39 | import Text.PrettyPrint.HughesPJClass (maybeParens, Pretty(pPrintPrec), PrettyLevel) 40 | 41 | -- | Atoms that support equality must be an instance of HasEquate 42 | class HasApply atom => HasEquate atom where 43 | equate :: TermOf atom -> TermOf atom -> atom 44 | -- ^ Create an equate predicate 45 | foldEquate :: (TermOf atom -> TermOf atom -> r) -> (PredOf atom -> [TermOf atom] -> r) -> atom -> r 46 | -- ^ Analyze whether a predicate is an equate or a regular apply. 47 | 48 | -- | Combine 'equate' and 'atomic' to build a formula from two terms. 49 | (.=.) :: (IsFormula formula, HasEquate atom, atom ~ AtomOf formula) => TermOf atom -> TermOf atom -> formula 50 | a .=. b = atomic (equate a b) 51 | infix 6 .=. 52 | 53 | -- | Zip two atoms that support equality 54 | zipEquates :: (HasEquate atom1, HasEquate atom2, PredOf atom1 ~ PredOf atom2) => 55 | (TermOf atom1 -> TermOf atom1 -> 56 | TermOf atom2 -> TermOf atom2 -> Maybe r) 57 | -> (PredOf atom1 -> [(TermOf atom1, TermOf atom2)] -> Maybe r) 58 | -> atom1 -> atom2 -> Maybe r 59 | zipEquates eq ap atom1 atom2 = 60 | foldEquate eq' ap' atom1 61 | where 62 | eq' l1 r1 = foldEquate (eq l1 r1) (\_ _ -> Nothing) atom2 63 | ap' p1 ts1 = foldEquate (\_ _ -> Nothing) (ap'' p1 ts1) atom2 64 | ap'' p1 ts1 p2 ts2 | p1 == p2 && length ts1 == length ts2 = ap p1 (zip ts1 ts2) 65 | ap'' _ _ _ _ = Nothing 66 | 67 | -- | Convert between HasEquate atom types. 68 | convertEquate :: (HasEquate atom1, HasEquate atom2) => 69 | (PredOf atom1 -> PredOf atom2) -> (TermOf atom1 -> TermOf atom2) -> atom1 -> atom2 70 | convertEquate cp ct = foldEquate (\t1 t2 -> equate (ct t1) (ct t2)) (\p1 ts1 -> applyPredicate (cp p1) (map ct ts1)) 71 | 72 | -- | Implementation of 'overterms' for 'HasEquate' types. 73 | overtermsEq :: HasEquate atom => ((TermOf atom) -> r -> r) -> r -> atom -> r 74 | overtermsEq f r0 = foldEquate (\t1 t2 -> f t2 (f t1 r0)) (\_ ts -> foldr f r0 ts) 75 | 76 | -- | Implementation of 'onterms' for 'HasEquate' types. 77 | ontermsEq :: HasEquate atom => ((TermOf atom) -> (TermOf atom)) -> atom -> atom 78 | ontermsEq f = foldEquate (\t1 t2 -> equate (f t1) (f t2)) (\p ts -> applyPredicate p (map f ts)) 79 | 80 | -- | Implementation of Show for 'HasEquate' types 81 | showApplyAndEquate :: (HasEquate atom, Show (TermOf atom)) => atom -> String 82 | showApplyAndEquate atom = foldEquate showEquate showApply atom 83 | 84 | showEquate :: Show term => term -> term -> String 85 | showEquate t1 t2 = "(" ++ show t1 ++ ") .=. (" ++ show t2 ++ ")" 86 | 87 | -- | Format the infix equality predicate applied to two terms. 88 | prettyEquate :: IsTerm term => PrettyLevel -> Rational -> term -> term -> Doc 89 | prettyEquate l p t1 t2 = 90 | maybeParens (p > atomPrec) $ pPrintPrec l atomPrec t1 <> text "=" <> pPrintPrec l atomPrec t2 91 | 92 | precedenceEquate :: HasEquate atom => atom -> Precedence 93 | precedenceEquate = foldEquate (\_ _ -> eqPrec) (\_ _ -> pAppPrec) 94 | 95 | associativityEquate :: HasEquate atom => atom -> Associativity 96 | associativityEquate = foldEquate (\_ _ -> Pretty.InfixN) (\_ _ -> Pretty.InfixN) 97 | 98 | -- | Instance of an atom type with a distinct equality predicate. 99 | data FOL predicate term = R predicate [term] | Equals term term deriving (Eq, Ord, Data, Typeable, Read) 100 | 101 | instance (IsPredicate predicate, IsTerm term) => HasEquate (FOL predicate term) where 102 | equate lhs rhs = Equals lhs rhs 103 | foldEquate eq _ (Equals lhs rhs) = eq lhs rhs 104 | foldEquate _ ap (R p ts) = ap p ts 105 | 106 | instance (IsPredicate predicate, IsTerm term) => IsAtom (FOL predicate term) 107 | 108 | instance (HasApply (FOL predicate term), 109 | HasEquate (FOL predicate term), IsTerm term) => Pretty (FOL predicate term) where 110 | pPrintPrec d r = foldEquate (prettyEquate d r) prettyApply 111 | 112 | instance (IsPredicate predicate, IsTerm term) => HasApply (FOL predicate term) where 113 | type PredOf (FOL predicate term) = predicate 114 | type TermOf (FOL predicate term) = term 115 | applyPredicate = R 116 | foldApply' _ f (R p ts) = f p ts 117 | foldApply' d _ x = d x 118 | overterms = overtermsEq 119 | onterms = ontermsEq 120 | 121 | instance (IsPredicate predicate, IsTerm term, Show predicate, Show term) => Show (FOL predicate term) where 122 | show = foldEquate (\t1 t2 -> showEquate (t1 :: term) (t2 :: term)) 123 | (\p ts -> showApply (p :: predicate) (ts :: [term])) 124 | 125 | instance (IsPredicate predicate, IsTerm term) => HasFixity (FOL predicate term) where 126 | precedence = precedenceEquate 127 | associativity = associativityEquate 128 | 129 | -- | An atom type with equality predicate 130 | type EqAtom = FOL Predicate FTerm 131 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/FOL.hs: -------------------------------------------------------------------------------- 1 | -- | Basic stuff for first order logic. 2 | -- 3 | -- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) 4 | 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FunctionalDependencies #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE OverloadedStrings #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module Data.Logic.ATP.FOL 18 | ( IsFirstOrder 19 | -- * Semantics 20 | , Interp 21 | , holds 22 | , holdsQuantified 23 | , holdsAtom 24 | , termval 25 | -- * Free Variables 26 | , var 27 | , fv, fva, fvt 28 | , generalize 29 | -- * Substitution 30 | , subst, substq, asubst, tsubst, lsubst 31 | , bool_interp 32 | , mod_interp 33 | -- * Concrete instances of formula types for use in unit tests. 34 | , ApFormula, EqFormula 35 | -- * Tests 36 | , testFOL 37 | ) where 38 | 39 | import Data.Logic.ATP.Apply (ApAtom, HasApply(PredOf, TermOf, overterms, onterms), Predicate) 40 | import Data.Logic.ATP.Equate ((.=.), EqAtom, foldEquate, HasEquate) 41 | import Data.Logic.ATP.Formulas (fromBool, IsFormula(..)) 42 | import Data.Logic.ATP.Lib (setAny, tryApplyD, undefine, (|->)) 43 | import Data.Logic.ATP.Lit ((.~.), foldLiteral, JustLiteral) 44 | import Data.Logic.ATP.Pretty (prettyShow) 45 | import Data.Logic.ATP.Prop (BinOp(..), IsPropositional((.&.), (.|.), (.=>.), (.<=>.))) 46 | import Data.Logic.ATP.Quantified (exists, foldQuantified, for_all, IsQuantified(VarOf), Quant((:!:), (:?:)), QFormula) 47 | import Data.Logic.ATP.Term (FName, foldTerm, IsTerm(FunOf, TVarOf, vt, fApp), V, variant) 48 | import Data.Map.Strict as Map (empty, fromList, insert, lookup, Map) 49 | import Data.Maybe (fromMaybe) 50 | import Data.Set as Set (difference, empty, fold, fromList, member, Set, singleton, union, unions) 51 | import Data.String (IsString(fromString)) 52 | import Prelude hiding (pred) 53 | import Test.HUnit 54 | 55 | -- | Combine IsQuantified, HasApply, IsTerm, and make sure the term is 56 | -- using the same variable type as the formula. 57 | class (IsQuantified formula, 58 | HasApply (AtomOf formula), 59 | IsTerm (TermOf (AtomOf formula)), 60 | VarOf formula ~ TVarOf (TermOf (AtomOf formula))) 61 | => IsFirstOrder formula 62 | 63 | -- | A formula type with no equality predicate 64 | type ApFormula = QFormula V ApAtom 65 | instance IsFirstOrder ApFormula 66 | 67 | -- | A formula type with equality predicate 68 | type EqFormula = QFormula V EqAtom 69 | instance IsFirstOrder EqFormula 70 | 71 | {- 72 | (* Trivial example of "x + y < z". *) 73 | (* ------------------------------------------------------------------------- *) 74 | 75 | START_INTERACTIVE;; 76 | Atom(R("<",[Fn("+",[Var "x"; Var "y"]); Var "z"]));; 77 | END_INTERACTIVE;; 78 | 79 | (* ------------------------------------------------------------------------- *) 80 | (* Parsing of terms. *) 81 | (* ------------------------------------------------------------------------- *) 82 | 83 | let is_const_name s = forall numeric (explode s) or s = "nil";; 84 | 85 | let rec parse_atomic_term vs inp = 86 | match inp with 87 | [] -> failwith "term expected" 88 | | "("::rest -> parse_bracketed (parse_term vs) ")" rest 89 | | "-"::rest -> papply (fun t -> Fn("-",[t])) (parse_atomic_term vs rest) 90 | | f::"("::")"::rest -> Fn(f,[]),rest 91 | | f::"("::rest -> 92 | papply (fun args -> Fn(f,args)) 93 | (parse_bracketed (parse_list "," (parse_term vs)) ")" rest) 94 | | a::rest -> 95 | (if is_const_name a & not(mem a vs) then Fn(a,[]) else Var a),rest 96 | 97 | and parse_term vs inp = 98 | parse_right_infix "::" (fun (e1,e2) -> Fn("::",[e1;e2])) 99 | (parse_right_infix "+" (fun (e1,e2) -> Fn("+",[e1;e2])) 100 | (parse_left_infix "-" (fun (e1,e2) -> Fn("-",[e1;e2])) 101 | (parse_right_infix "*" (fun (e1,e2) -> Fn("*",[e1;e2])) 102 | (parse_left_infix "/" (fun (e1,e2) -> Fn("/",[e1;e2])) 103 | (parse_left_infix "^" (fun (e1,e2) -> Fn("^",[e1;e2])) 104 | (parse_atomic_term vs)))))) inp;; 105 | 106 | let parset = make_parser (parse_term []);; 107 | 108 | (* ------------------------------------------------------------------------- *) 109 | (* Parsing of formulas. *) 110 | (* ------------------------------------------------------------------------- *) 111 | 112 | let parse_infix_atom vs inp = 113 | let tm,rest = parse_term vs inp in 114 | if exists (nextin rest) ["="; "<"; "<="; ">"; ">="] then 115 | papply (fun tm' -> Atom(R(hd rest,[tm;tm']))) 116 | (parse_term vs (tl rest)) 117 | else failwith "";; 118 | 119 | let parse_atom vs inp = 120 | try parse_infix_atom vs inp with Failure _ -> 121 | match inp with 122 | | p::"("::")"::rest -> Atom(R(p,[])),rest 123 | | p::"("::rest -> 124 | papply (fun args -> Atom(R(p,args))) 125 | (parse_bracketed (parse_list "," (parse_term vs)) ")" rest) 126 | | p::rest when p <> "(" -> Atom(R(p,[])),rest 127 | | _ -> failwith "parse_atom";; 128 | 129 | let parse = make_parser 130 | (parse_formula (parse_infix_atom,parse_atom) []);; 131 | 132 | (* ------------------------------------------------------------------------- *) 133 | (* Set up parsing of quotations. *) 134 | (* ------------------------------------------------------------------------- *) 135 | 136 | let default_parser = parse;; 137 | 138 | let secondary_parser = parset;; 139 | 140 | {- 141 | (* ------------------------------------------------------------------------- *) 142 | (* Example. *) 143 | (* ------------------------------------------------------------------------- *) 144 | 145 | START_INTERACTIVE;; 146 | <<(forall x. x < 2 ==> 2 * x <= 3) \/ false>>;; 147 | 148 | <<|2 * x|>>;; 149 | END_INTERACTIVE;; 150 | -} 151 | 152 | (* ------------------------------------------------------------------------- *) 153 | (* Printing of terms. *) 154 | (* ------------------------------------------------------------------------- *) 155 | 156 | let rec print_term prec fm = 157 | match fm with 158 | Var x -> print_string x 159 | | Fn("^",[tm1;tm2]) -> print_infix_term true prec 24 "^" tm1 tm2 160 | | Fn("/",[tm1;tm2]) -> print_infix_term true prec 22 " /" tm1 tm2 161 | | Fn("*",[tm1;tm2]) -> print_infix_term false prec 20 " *" tm1 tm2 162 | | Fn("-",[tm1;tm2]) -> print_infix_term true prec 18 " -" tm1 tm2 163 | | Fn("+",[tm1;tm2]) -> print_infix_term false prec 16 " +" tm1 tm2 164 | | Fn("::",[tm1;tm2]) -> print_infix_term false prec 14 "::" tm1 tm2 165 | | Fn(f,args) -> print_fargs f args 166 | 167 | and print_fargs f args = 168 | print_string f; 169 | if args = [] then () else 170 | (print_string "("; 171 | open_box 0; 172 | print_term 0 (hd args); print_break 0 0; 173 | do_list (fun t -> print_string ","; print_break 0 0; print_term 0 t) 174 | (tl args); 175 | close_box(); 176 | print_string ")") 177 | 178 | and print_infix_term isleft oldprec newprec sym p q = 179 | if oldprec > newprec then (print_string "("; open_box 0) else (); 180 | print_term (if isleft then newprec else newprec+1) p; 181 | print_string sym; 182 | print_break (if String.sub sym 0 1 = " " then 1 else 0) 0; 183 | print_term (if isleft then newprec+1 else newprec) q; 184 | if oldprec > newprec then (close_box(); print_string ")") else ();; 185 | 186 | let printert tm = 187 | open_box 0; print_string "<<|"; 188 | open_box 0; print_term 0 tm; close_box(); 189 | print_string "|>>"; close_box();; 190 | 191 | #install_printer printert;; 192 | 193 | (* ------------------------------------------------------------------------- *) 194 | (* Printing of formulas. *) 195 | (* ------------------------------------------------------------------------- *) 196 | 197 | let print_atom prec (R(p,args)) = 198 | if mem p ["="; "<"; "<="; ">"; ">="] & length args = 2 199 | then print_infix_term false 12 12 (" "^p) (el 0 args) (el 1 args) 200 | else print_fargs p args;; 201 | 202 | let print_fol_formula = print_qformula print_atom;; 203 | 204 | #install_printer print_fol_formula;; 205 | 206 | (* ------------------------------------------------------------------------- *) 207 | (* Examples in the main text. *) 208 | (* ------------------------------------------------------------------------- *) 209 | 210 | START_INTERACTIVE;; 211 | <>;; 212 | 213 | <<~(forall x. P(x)) <=> exists y. ~P(y)>>;; 214 | END_INTERACTIVE;; 215 | -} 216 | 217 | -- | Specify the domain of a formula interpretation, and how to 218 | -- interpret its functions and predicates. 219 | data Interp function predicate d 220 | = Interp { domain :: [d] 221 | , funcApply :: function -> [d] -> d 222 | , predApply :: predicate -> [d] -> Bool 223 | , eqApply :: d -> d -> Bool } 224 | 225 | -- | The holds function computes the value of a formula for a finite domain. 226 | class FiniteInterpretation a function predicate v dom where 227 | holds :: Interp function predicate dom -> Map v dom -> a -> Bool 228 | 229 | -- | Implementation of holds for IsQuantified formulas. 230 | holdsQuantified :: forall formula function predicate dom. 231 | (IsQuantified formula, 232 | FiniteInterpretation (AtomOf formula) function predicate (VarOf formula) dom, 233 | FiniteInterpretation formula function predicate (VarOf formula) dom) => 234 | Interp function predicate dom -> Map (VarOf formula) dom -> formula -> Bool 235 | holdsQuantified m v fm = 236 | foldQuantified qu co ne tf at fm 237 | where 238 | qu (:!:) x p = and (map (\a -> holds m (Map.insert x a v) p) (domain m)) -- >>= return . any (== True) 239 | qu (:?:) x p = or (map (\a -> holds m (Map.insert x a v) p) (domain m)) -- return . all (== True)? 240 | ne p = not (holds m v p) 241 | co p (:&:) q = (holds m v p) && (holds m v q) 242 | co p (:|:) q = (holds m v p) || (holds m v q) 243 | co p (:=>:) q = not (holds m v p) || (holds m v q) 244 | co p (:<=>:) q = (holds m v p) == (holds m v q) 245 | tf x = x 246 | at = (holds m v :: AtomOf formula -> Bool) 247 | 248 | -- | Implementation of holds for atoms with equate predicates. 249 | holdsAtom :: (HasEquate atom, IsTerm term, Eq dom, 250 | term ~ TermOf atom, v ~ TVarOf term, function ~ FunOf term, predicate ~ PredOf atom) => 251 | Interp function predicate dom -> Map v dom -> atom -> Bool 252 | holdsAtom m v at = foldEquate (\t1 t2 -> eqApply m (termval m v t1) (termval m v t2)) 253 | (\r args -> predApply m r (map (termval m v) args)) at 254 | 255 | termval :: (IsTerm term, v ~ TVarOf term, function ~ FunOf term) => Interp function predicate r -> Map v r -> term -> r 256 | termval m v tm = 257 | foldTerm (\x -> fromMaybe (error ("Undefined variable: " ++ show x)) (Map.lookup x v)) 258 | (\f args -> funcApply m f (map (termval m v) args)) tm 259 | 260 | {- 261 | START_INTERACTIVE;; 262 | holds bool_interp undefined <>;; 263 | 264 | holds (mod_interp 2) undefined <>;; 265 | 266 | holds (mod_interp 3) undefined <>;; 267 | 268 | let fm = < exists y. x * y = 1>>;; 269 | 270 | filter (fun n -> holds (mod_interp n) undefined fm) (1--45);; 271 | 272 | holds (mod_interp 3) undefined <<(forall x. x = 0) ==> 1 = 0>>;; 273 | holds (mod_interp 3) undefined < 1 = 0>>;; 274 | END_INTERACTIVE;; 275 | -} 276 | 277 | -- | Examples of particular interpretations. 278 | bool_interp :: Interp FName Predicate Bool 279 | bool_interp = 280 | Interp [False, True] func pred (==) 281 | where 282 | func f [] | f == fromString "False" = False 283 | func f [] | f == fromString "True" = True 284 | func f [x,y] | f == fromString "+" = x /= y 285 | func f [x,y] | f == fromString "*" = x && y 286 | func f _ = error ("bool_interp - uninterpreted function: " ++ show f) 287 | pred p _ = error ("bool_interp - uninterpreted predicate: " ++ show p) 288 | 289 | mod_interp :: Int -> Interp FName Predicate Int 290 | mod_interp n = 291 | Interp [0..(n-1)] func pred (==) 292 | where 293 | func f [] | f == fromString "0" = 0 294 | func f [] | f == fromString "1" = 1 `mod` n 295 | func f [x,y] | f == fromString "+" = (x + y) `mod` n 296 | func f [x,y] | f == fromString "*" = (x * y) `mod` n 297 | func f _ = error ("mod_interp - uninterpreted function: " ++ show f) 298 | pred p _ = error ("mod_interp - uninterpreted predicate: " ++ show p) 299 | 300 | instance Eq dom => FiniteInterpretation EqFormula FName Predicate V dom where holds = holdsQuantified 301 | instance Eq dom => FiniteInterpretation EqAtom FName Predicate V dom where holds = holdsAtom 302 | 303 | test01 :: Test 304 | test01 = TestCase $ assertEqual "holds bool test (p. 126)" expected input 305 | where input = holds bool_interp (Map.empty :: Map V Bool) (for_all "x" ((vt "x") .=. (fApp "False" []) .|. (vt "x") .=. (fApp "True" [])) :: EqFormula) 306 | expected = True 307 | test02 :: Test 308 | test02 = TestCase $ assertEqual "holds mod test 1 (p. 126)" expected input 309 | where input = holds (mod_interp 2) (Map.empty :: Map V Int) (for_all "x" (vt "x" .=. (fApp "0" []) .|. vt "x" .=. (fApp "1" [])) :: EqFormula) 310 | expected = True 311 | test03 :: Test 312 | test03 = TestCase $ assertEqual "holds mod test 2 (p. 126)" expected input 313 | where input = holds (mod_interp 3) (Map.empty :: Map V Int) (for_all "x" (vt "x" .=. fApp "0" [] .|. vt "x" .=. fApp "1" []) :: EqFormula) 314 | expected = False 315 | 316 | test04 :: Test 317 | test04 = TestCase $ assertEqual "holds mod test 3 (p. 126)" expected input 318 | where input = filter (\ n -> holds (mod_interp n) (Map.empty :: Map V Int) fm) [1..45] 319 | where fm = for_all "x" ((.~.) (vt "x" .=. fApp "0" []) .=>. exists "y" (fApp "*" [vt "x", vt "y"] .=. fApp "1" [])) :: EqFormula 320 | expected = [1,2,3,5,7,11,13,17,19,23,29,31,37,41,43] 321 | 322 | test05 :: Test 323 | test05 = TestCase $ assertEqual "holds mod test 4 (p. 129)" expected input 324 | where input = holds (mod_interp 3) (Map.empty :: Map V Int) ((for_all "x" (vt "x" .=. fApp "0" [])) .=>. fApp "1" [] .=. fApp "0" [] :: EqFormula) 325 | expected = True 326 | test06 :: Test 327 | test06 = TestCase $ assertEqual "holds mod test 5 (p. 129)" expected input 328 | where input = holds (mod_interp 3) (Map.empty :: Map V Int) (for_all "x" (vt "x" .=. fApp "0" [] .=>. fApp "1" [] .=. fApp "0" []) :: EqFormula) 329 | expected = False 330 | 331 | -- Free variables in terms and formulas. 332 | 333 | -- | Find the free variables in a formula. 334 | fv :: (IsFirstOrder formula, v ~ VarOf formula) => formula -> Set v 335 | fv fm = 336 | foldQuantified qu co ne tf at fm 337 | where 338 | qu _ x p = difference (fv p) (singleton x) 339 | ne p = fv p 340 | co p _ q = union (fv p) (fv q) 341 | tf _ = Set.empty 342 | at = fva 343 | 344 | -- | Find all the variables in a formula. 345 | -- var :: (IsFirstOrder formula, v ~ VarOf formula) => formula -> Set v 346 | var :: (IsFormula formula, HasApply atom, 347 | atom ~ AtomOf formula, term ~ TermOf atom, v ~ TVarOf term) => 348 | formula -> Set v 349 | var fm = overatoms (\a s -> Set.union (fva a) s) fm mempty 350 | 351 | -- | Find the variables in an atom 352 | fva :: (HasApply atom, IsTerm term, term ~ TermOf atom, v ~ TVarOf term) => atom -> Set v 353 | fva = overterms (\t s -> Set.union (fvt t) s) mempty 354 | 355 | -- | Find the variables in a term 356 | fvt :: (IsTerm term, v ~ TVarOf term) => term -> Set v 357 | fvt tm = foldTerm singleton (\_ args -> unions (map fvt args)) tm 358 | 359 | -- | Universal closure of a formula. 360 | generalize :: IsFirstOrder formula => formula -> formula 361 | generalize fm = Set.fold for_all fm (fv fm) 362 | 363 | test07 :: Test 364 | test07 = TestCase $ assertEqual "variant 1 (p. 133)" expected input 365 | where input = variant "x" (Set.fromList ["y", "z"]) :: V 366 | expected = "x" 367 | test08 :: Test 368 | test08 = TestCase $ assertEqual "variant 2 (p. 133)" expected input 369 | where input = variant "x" (Set.fromList ["x", "y"]) :: V 370 | expected = "x'" 371 | test09 :: Test 372 | test09 = TestCase $ assertEqual "variant 3 (p. 133)" expected input 373 | where input = variant "x" (Set.fromList ["x", "x'"]) :: V 374 | expected = "x''" 375 | 376 | -- | Substitution in formulas, with variable renaming. 377 | subst :: (IsFirstOrder formula, term ~ TermOf (AtomOf formula), v ~ VarOf formula) => Map v term -> formula -> formula 378 | subst subfn fm = 379 | foldQuantified qu co ne tf at fm 380 | where 381 | qu (:!:) x p = substq subfn for_all x p 382 | qu (:?:) x p = substq subfn exists x p 383 | ne p = (.~.) (subst subfn p) 384 | co p (:&:) q = (subst subfn p) .&. (subst subfn q) 385 | co p (:|:) q = (subst subfn p) .|. (subst subfn q) 386 | co p (:=>:) q = (subst subfn p) .=>. (subst subfn q) 387 | co p (:<=>:) q = (subst subfn p) .<=>. (subst subfn q) 388 | tf False = false 389 | tf True = true 390 | at = atomic . asubst subfn 391 | 392 | -- | Substitution within terms. 393 | tsubst :: (IsTerm term, v ~ TVarOf term) => Map v term -> term -> term 394 | tsubst sfn tm = 395 | foldTerm (\x -> fromMaybe tm (Map.lookup x sfn)) 396 | (\f args -> fApp f (map (tsubst sfn) args)) 397 | tm 398 | 399 | -- | Substitution within a Literal 400 | lsubst :: (JustLiteral lit, HasApply atom, IsTerm term, 401 | atom ~ AtomOf lit, 402 | term ~ TermOf atom, 403 | v ~ TVarOf term) => 404 | Map v term -> lit -> lit 405 | lsubst subfn fm = 406 | foldLiteral ne fromBool at fm 407 | where 408 | ne p = (.~.) (lsubst subfn p) 409 | at = atomic . asubst subfn 410 | 411 | -- | Substitution within atoms. 412 | asubst :: (HasApply atom, IsTerm term, term ~ TermOf atom, v ~ TVarOf term) => Map v term -> atom -> atom 413 | asubst sfn a = onterms (tsubst sfn) a 414 | 415 | -- | Substitution within quantifiers 416 | substq :: (IsFirstOrder formula, v ~ VarOf formula, term ~ TermOf (AtomOf formula)) => 417 | Map v term -> (v -> formula -> formula) -> v -> formula -> formula 418 | substq subfn qu x p = 419 | let x' = if setAny (\y -> Set.member x (fvt(tryApplyD subfn y (vt y)))) 420 | (difference (fv p) (singleton x)) 421 | then variant x (fv (subst (undefine x subfn) p)) else x in 422 | qu x' (subst ((x |-> vt x') subfn) p) 423 | 424 | -- Examples. 425 | 426 | test10 :: Test 427 | test10 = 428 | let [x, x', y] = [vt "x", vt "x'", vt "y"] 429 | fm = for_all "x" ((x .=. y)) :: EqFormula 430 | expected = for_all "x'" (x' .=. x) :: EqFormula in 431 | TestCase $ assertEqual ("subst (\"y\" |=> Var \"x\") " ++ prettyShow fm ++ " (p. 134)") 432 | expected 433 | (subst (Map.fromList [("y", x)]) fm) 434 | 435 | test11 :: Test 436 | test11 = 437 | let [x, x', x'', y] = [vt "x", vt "x'", vt "x''", vt "y"] 438 | fm = (for_all "x" (for_all "x'" ((x .=. y) .=>. (x .=. x')))) :: EqFormula 439 | expected = for_all "x'" (for_all "x''" ((x' .=. x) .=>. ((x' .=. x'')))) :: EqFormula in 440 | TestCase $ assertEqual ("subst (\"y\" |=> Var \"x\") " ++ prettyShow fm ++ " (p. 134)") 441 | expected 442 | (subst (Map.fromList [("y", x)]) fm) 443 | 444 | testFOL :: Test 445 | testFOL = TestLabel "FOL" (TestList [test01, test02, test03, test04, 446 | test05, test06, test07, test08, test09, 447 | test10, test11]) 448 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/Formulas.hs: -------------------------------------------------------------------------------- 1 | -- | The 'IsFormula' class contains definitions for the boolean true 2 | -- and false values, and methods for traversing the atoms of a formula. 3 | 4 | {-# LANGUAGE DeriveDataTypeable #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE FunctionalDependencies #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | 12 | module Data.Logic.ATP.Formulas 13 | ( IsAtom 14 | , IsFormula(AtomOf, true, false, asBool, atomic, overatoms, onatoms) 15 | , (⊥), (⊤) 16 | , fromBool 17 | , prettyBool 18 | , atom_union 19 | ) where 20 | 21 | import Data.Logic.ATP.Pretty (Doc, HasFixity, Pretty, text) 22 | import Data.Set as Set (Set, empty, union) 23 | import Prelude hiding (negate) 24 | 25 | -- | Basic properties of an atomic formula 26 | class (Ord atom, Show atom, HasFixity atom, Pretty atom) => IsAtom atom 27 | 28 | -- | Class associating a formula type with its atom (atomic formula) type. 29 | class (Pretty formula, HasFixity formula, IsAtom (AtomOf formula)) => IsFormula formula where 30 | type AtomOf formula 31 | -- ^ AtomOf is a function that maps the formula type to the 32 | -- associated atomic formula type 33 | true :: formula 34 | -- ^ The true element 35 | false :: formula 36 | -- ^ The false element 37 | asBool :: formula -> Maybe Bool 38 | -- ^ If the arugment is true or false return the corresponding 39 | -- 'Bool', otherwise return 'Nothing'. 40 | atomic :: AtomOf formula -> formula 41 | -- ^ Build a formula from an atom. 42 | overatoms :: (AtomOf formula -> r -> r) -> formula -> r -> r 43 | -- ^ Formula analog of iterator 'foldr'. 44 | onatoms :: (AtomOf formula -> AtomOf formula) -> formula -> formula 45 | -- ^ Apply a function to the atoms, otherwise keeping structure (new sig) 46 | 47 | (⊤) :: IsFormula p => p 48 | (⊤) = true 49 | 50 | (⊥) :: IsFormula p => p 51 | (⊥) = false 52 | 53 | fromBool :: IsFormula formula => Bool -> formula 54 | fromBool True = true 55 | fromBool False = false 56 | 57 | prettyBool :: Bool -> Doc 58 | prettyBool True = text "⊤" 59 | prettyBool False = text "⊥" 60 | 61 | -- | Special case of a union of the results of a function over the atoms. 62 | atom_union :: (IsFormula formula, Ord r) => (AtomOf formula -> Set r) -> formula -> Set r 63 | atom_union f fm = overatoms (\h t -> Set.union (f h) t) fm Set.empty 64 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/Herbrand.hs: -------------------------------------------------------------------------------- 1 | -- | Relation between FOL and propositonal logic; Herbrand theorem. 2 | -- 3 | -- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) 4 | 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE QuasiQuotes #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | 14 | module Data.Logic.ATP.Herbrand where 15 | 16 | import Data.Logic.ATP.Apply (functions, HasApply(TermOf)) 17 | import Data.Logic.ATP.DP (dpll) 18 | import Data.Logic.ATP.FOL (IsFirstOrder, lsubst, fv, generalize) 19 | import Data.Logic.ATP.Formulas (IsFormula(AtomOf), overatoms, atomic) 20 | import Data.Logic.ATP.Lib (allpairs, distrib) 21 | import Data.Logic.ATP.Lit ((.~.), JustLiteral, LFormula) 22 | import Data.Logic.ATP.Parser(fof) 23 | import Data.Logic.ATP.Pretty (prettyShow) 24 | import Data.Logic.ATP.Prop (eval, JustPropositional, PFormula, simpcnf, simpdnf, trivial) 25 | import Data.Logic.ATP.Skolem (Formula, HasSkolem(SVarOf), runSkolem, skolemize) 26 | import Data.Logic.ATP.Term (Arity, IsTerm(TVarOf, FunOf), fApp) 27 | import qualified Data.Map.Strict as Map 28 | import Data.Set as Set 29 | import Data.String (IsString(..)) 30 | import Debug.Trace 31 | import Test.HUnit hiding (tried) 32 | 33 | -- | Propositional valuation. 34 | pholds :: (JustPropositional pf) => (AtomOf pf -> Bool) -> pf -> Bool 35 | pholds d fm = eval fm d 36 | 37 | -- | Get the constants for Herbrand base, adding nullary one if necessary. 38 | herbfuns :: (atom ~ AtomOf fof, term ~ TermOf atom, function ~ FunOf term, IsFormula fof, HasApply atom, Ord function) => fof -> (Set (function, Arity), Set (function, Arity)) 39 | herbfuns fm = 40 | let (cns,fns) = Set.partition (\ (_,ar) -> ar == 0) (functions fm) in 41 | if Set.null cns then (Set.singleton (fromString "c",0),fns) else (cns,fns) 42 | 43 | -- | Enumeration of ground terms and m-tuples, ordered by total fns. 44 | groundterms :: (v ~ TVarOf term, f ~ FunOf term, IsTerm term) => Set term -> Set (f, Arity) -> Int -> Set term 45 | groundterms cntms _ 0 = cntms 46 | groundterms cntms fns n = 47 | Set.fold terms Set.empty fns 48 | where 49 | terms (f,m) l = Set.union (Set.map (fApp f) (groundtuples cntms fns (n - 1) m)) l 50 | 51 | groundtuples :: (v ~ TVarOf term, f ~ FunOf term, IsTerm term) => Set term -> Set (f, Int) -> Int -> Int -> Set [term] 52 | groundtuples _ _ 0 0 = Set.singleton [] 53 | groundtuples _ _ _ 0 = Set.empty 54 | groundtuples cntms fns n m = 55 | Set.fold tuples Set.empty (Set.fromList [0 .. n]) 56 | where 57 | tuples k l = Set.union (allpairs (:) (groundterms cntms fns k) (groundtuples cntms fns (n - k) (m - 1))) l 58 | 59 | -- | Iterate modifier "mfn" over ground terms till "tfn" fails. 60 | herbloop :: forall lit atom function v term. 61 | (atom ~ AtomOf lit, term ~ TermOf atom, function ~ FunOf term, v ~ TVarOf term, v ~ SVarOf function, 62 | JustLiteral lit, 63 | HasApply atom, 64 | IsTerm term) => 65 | (Set (Set lit) -> (lit -> lit) -> Set (Set lit) -> Set (Set lit)) 66 | -> (Set (Set lit) -> Bool) 67 | -> Set (Set lit) 68 | -> Set term 69 | -> Set (function, Int) 70 | -> [TVarOf term] 71 | -> Int 72 | -> Set (Set lit) 73 | -> Set [term] 74 | -> Set [term] 75 | -> Set [term] 76 | herbloop mfn tfn fl0 cntms fns fvs n fl tried tuples = 77 | let debug x = trace (show (size tried) ++ " ground instances tried; " ++ show (length fl) ++ " items in list") x in 78 | case Set.minView (debug tuples) of 79 | Nothing -> 80 | let newtups = groundtuples cntms fns n (length fvs) in 81 | herbloop mfn tfn fl0 cntms fns fvs (n + 1) fl tried newtups 82 | Just (tup, tups) -> 83 | let fpf' = Map.fromList (zip fvs tup) in 84 | let fl' = mfn fl0 (lsubst fpf') fl in 85 | if not (tfn fl') then Set.insert tup tried 86 | else herbloop mfn tfn fl0 cntms fns fvs n fl' (Set.insert tup tried) tups 87 | 88 | -- | Hence a simple Gilmore-type procedure. 89 | gilmore_loop :: (atom ~ AtomOf lit, term ~ TermOf atom, function ~ FunOf term, v ~ TVarOf term, v ~ SVarOf function, 90 | JustLiteral lit, Ord lit, 91 | HasApply atom, 92 | IsTerm term) => 93 | Set (Set lit) 94 | -> Set term 95 | -> Set (function, Int) 96 | -> [TVarOf term] 97 | -> Int 98 | -> Set (Set lit) 99 | -> Set [term] 100 | -> Set [term] 101 | -> Set [term] 102 | gilmore_loop = 103 | herbloop mfn (not . Set.null) 104 | where 105 | mfn djs0 ifn djs = Set.filter (not . trivial) (distrib (Set.map (Set.map ifn) djs0) djs) 106 | 107 | gilmore :: forall fof atom term v function. 108 | (IsFirstOrder fof, Ord fof, HasSkolem function, 109 | atom ~ AtomOf fof, 110 | term ~ TermOf atom, 111 | function ~ FunOf term, 112 | v ~ TVarOf term, 113 | v ~ SVarOf function) => 114 | fof -> Int 115 | gilmore fm = 116 | let (sfm :: PFormula atom) = runSkolem (skolemize id ((.~.) (generalize fm))) in 117 | let fvs = Set.toList (overatoms (\ a s -> Set.union s (fv (atomic a :: fof))) sfm (Set.empty)) 118 | (consts,fns) = herbfuns sfm in 119 | let cntms = Set.map (\ (c,_) -> fApp c []) consts in 120 | Set.size (gilmore_loop (simpdnf id sfm :: Set (Set (LFormula atom))) cntms fns (fvs) 0 (Set.singleton Set.empty) Set.empty Set.empty) 121 | 122 | -- | First example and a little tracing. 123 | test01 :: Test 124 | test01 = 125 | let fm = [fof| exists x. (forall y. p(x) ==> p(y)) |] 126 | expected = 2 127 | in 128 | TestCase (assertString (case gilmore fm of 129 | r | r == expected -> "" 130 | r -> "gilmore(" ++ prettyShow fm ++ ") -> " ++ show r ++ ", expected: " ++ show expected)) 131 | 132 | -- ------------------------------------------------------------------------- 133 | -- Quick example. 134 | -- ------------------------------------------------------------------------- 135 | 136 | p24 :: Test 137 | p24 = 138 | let label = "gilmore p24 (p. 160): " ++ prettyShow fm 139 | fm = [fof|~(exists x. (U(x) & Q(x))) & 140 | (forall x. (P(x) ==> Q(x) | R(x))) & 141 | ~(exists x. (P(x) ==> (exists x. Q(x)))) & 142 | (forall x. (Q(x) & R(x) ==> U(x))) 143 | ==> (exists x. (P(x) & R(x)))|] in 144 | TestLabel label $ TestCase $ assertEqual label 1 (gilmore fm) 145 | 146 | -- | Slightly less easy example. Expected output: 147 | -- 148 | -- 0 ground instances tried; 1 items in list 149 | -- 0 ground instances tried; 1 items in list 150 | -- 1 ground instances tried; 13 items in list 151 | -- 1 ground instances tried; 13 items in list 152 | -- 2 ground instances tried; 57 items in list 153 | -- 3 ground instances tried; 84 items in list 154 | -- 4 ground instances tried; 405 items in list 155 | p45fm :: Formula 156 | p45fm = [fof| (((forall x. 157 | ((P(x) & (forall y. ((G(y) & H(x,y)) ==> J(x,y)))) ==> 158 | (forall y. ((G(y) & H(x,y)) ==> R(y))))) & 159 | ((~(exists y. (L(y) & R(y)))) & 160 | (exists x. 161 | (P(x) & 162 | ((forall y. (H(x,y) ==> L(y))) & 163 | (forall y. ((G(y) & H(x,y)) ==> J(x,y)))))))) ==> 164 | (exists x. (P(x) & (~(exists y. (G(y) & H(x,y))))))) |] 165 | p45 :: Test 166 | p45 = TestLabel "gilmore p45" $ TestCase $ assertEqual "gilmore p45" 5 (gilmore p45fm) 167 | {- 168 | let p24 = gilmore 169 | <<~(exists x. U(x) /\ Q(x)) /\ 170 | (forall x. P(x) ==> Q(x) \/ R(x)) /\ 171 | ~(exists x. P(x) ==> (exists x. Q(x))) /\ 172 | (forall x. Q(x) /\ R(x) ==> U(x)) 173 | ==> (exists x. P(x) /\ R(x))>>;; 174 | -} 175 | {- 176 | -- ------------------------------------------------------------------------- 177 | -- Slightly less easy example. 178 | -- ------------------------------------------------------------------------- 179 | 180 | let p45 = gilmore 181 | <<(forall x. P(x) /\ (forall y. G(y) /\ H(x,y) ==> J(x,y)) 182 | ==> (forall y. G(y) /\ H(x,y) ==> R(y))) /\ 183 | ~(exists y. L(y) /\ R(y)) /\ 184 | (exists x. P(x) /\ (forall y. H(x,y) ==> L(y)) /\ 185 | (forall y. G(y) /\ H(x,y) ==> J(x,y))) 186 | ==> (exists x. P(x) /\ ~(exists y. G(y) /\ H(x,y)))>>;; 187 | END_INTERACTIVE;; 188 | -} 189 | -- ------------------------------------------------------------------------- 190 | -- Apparently intractable example. 191 | -- ------------------------------------------------------------------------- 192 | 193 | {- 194 | 195 | let p20 = gilmore 196 | <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w)) 197 | ==> (exists x y. P(x) /\ Q(y)) ==> (exists z. R(z))>>;; 198 | 199 | -} 200 | 201 | -- | The Davis-Putnam procedure for first order logic. 202 | dp_mfn :: Ord b => Set (Set a) -> (a -> b) -> Set (Set b) -> Set (Set b) 203 | dp_mfn cjs0 ifn cjs = Set.union (Set.map (Set.map ifn) cjs0) cjs 204 | 205 | dp_loop :: (atom ~ AtomOf lit, term ~ TermOf atom, function ~ FunOf term, v ~ TVarOf term, v ~ SVarOf function, 206 | JustLiteral lit, Ord lit, 207 | HasApply atom, 208 | IsTerm term) => 209 | Set (Set lit) 210 | -> Set term 211 | -> Set (function, Int) 212 | -> [v] 213 | -> Int 214 | -> Set (Set lit) 215 | -> Set [term] 216 | -> Set [term] 217 | -> Set [term] 218 | dp_loop = herbloop dp_mfn dpll 219 | 220 | davisputnam :: forall formula atom term v function. 221 | (IsFirstOrder formula, Ord formula, HasSkolem function, 222 | atom ~ AtomOf formula, 223 | term ~ TermOf atom, 224 | function ~ FunOf term, 225 | v ~ TVarOf term, 226 | v ~ SVarOf function) => 227 | formula -> Int 228 | davisputnam fm = 229 | let (sfm :: PFormula atom) = runSkolem (skolemize id ((.~.)(generalize fm))) in 230 | let fvs = Set.toList (overatoms (\ a s -> Set.union (fv (atomic a :: formula)) s) sfm Set.empty) 231 | (consts,fns) = herbfuns sfm in 232 | let cntms = Set.map (\ (c,_) -> fApp c []) consts in 233 | Set.size (dp_loop (simpcnf id sfm :: Set (Set (LFormula atom))) cntms fns fvs 0 Set.empty Set.empty Set.empty) 234 | 235 | {- 236 | -- | Show how much better than the Gilmore procedure this can be. 237 | START_INTERACTIVE;; 238 | let p20 = davisputnam 239 | <<(forall x y. exists z. forall w. P(x) /\ Q(y) ==> R(z) /\ U(w)) 240 | ==> (exists x y. P(x) /\ Q(y)) ==> (exists z. R(z))>>;; 241 | END_INTERACTIVE;; 242 | -} 243 | 244 | -- | Show how few of the instances we really need. Hence unification! 245 | davisputnam' :: forall formula atom term v function. 246 | (IsFirstOrder formula, Ord formula, HasSkolem function, 247 | atom ~ AtomOf formula, 248 | term ~ TermOf atom, 249 | function ~ FunOf term, 250 | v ~ TVarOf term, 251 | v ~ SVarOf function) => 252 | formula -> formula -> formula -> Int 253 | davisputnam' _ _ fm = 254 | let (sfm :: PFormula atom) = runSkolem (skolemize id ((.~.)(generalize fm))) in 255 | let fvs = Set.toList (overatoms (\ (a :: AtomOf formula) s -> Set.union (fv (atomic a :: formula)) s) sfm Set.empty) 256 | consts :: Set (function, Arity) 257 | fns :: Set (function, Arity) 258 | (consts,fns) = herbfuns sfm in 259 | let cntms :: Set (TermOf (AtomOf formula)) 260 | cntms = Set.map (\ (c,_) -> fApp c []) consts in 261 | Set.size (dp_refine_loop (simpcnf id sfm :: Set (Set (LFormula atom))) cntms fns fvs 0 Set.empty Set.empty Set.empty) 262 | 263 | -- | Try to cut out useless instantiations in final result. 264 | dp_refine_loop :: (atom ~ AtomOf lit, term ~ TermOf atom, function ~ FunOf term, v ~ TVarOf term, v ~ SVarOf function, 265 | JustLiteral lit, Ord lit, 266 | IsTerm term, 267 | HasApply atom) => 268 | Set (Set lit) 269 | -> Set term 270 | -> Set (function, Int) 271 | -> [v] 272 | -> Int 273 | -> Set (Set lit) 274 | -> Set [term] 275 | -> Set [term] 276 | -> Set [term] 277 | dp_refine_loop cjs0 cntms fns fvs n cjs tried tuples = 278 | let tups = dp_loop cjs0 cntms fns fvs n cjs tried tuples in 279 | dp_refine cjs0 fvs tups Set.empty 280 | 281 | dp_refine :: (atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term, 282 | HasApply atom, 283 | JustLiteral lit, Ord lit, 284 | IsTerm term 285 | ) => Set (Set lit) -> [TVarOf term] -> Set [term] -> Set [term] -> Set [term] 286 | dp_refine cjs0 fvs dknow need = 287 | case Set.minView dknow of 288 | Nothing -> need 289 | Just (cl, dknow') -> 290 | let mfn = dp_mfn cjs0 . lsubst . Map.fromList . zip fvs in 291 | let flag = dpll (Set.fold mfn Set.empty (Set.union need dknow')) in 292 | dp_refine cjs0 fvs dknow' (if flag then Set.insert cl need else need) 293 | 294 | {- 295 | START_INTERACTIVE;; 296 | let p36 = davisputnam' 297 | <<(forall x. exists y. P(x,y)) /\ 298 | (forall x. exists y. G(x,y)) /\ 299 | (forall x y. P(x,y) \/ G(x,y) 300 | ==> (forall z. P(y,z) \/ G(y,z) ==> H(x,z))) 301 | ==> (forall x. exists y. H(x,y))>>;; 302 | 303 | let p29 = davisputnam' 304 | <<(exists x. P(x)) /\ (exists x. G(x)) ==> 305 | ((forall x. P(x) ==> H(x)) /\ (forall x. G(x) ==> J(x)) <=> 306 | (forall x y. P(x) /\ G(y) ==> H(x) /\ J(y)))>>;; 307 | END_INTERACTIVE;; 308 | -} 309 | 310 | testHerbrand :: Test 311 | testHerbrand = TestLabel "Herbrand" (TestList [test01, p24, p45]) 312 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/Lit.hs: -------------------------------------------------------------------------------- 1 | -- | 'IsLiteral' is a subclass of formulas that support negation and 2 | -- have true and false elements. 3 | 4 | {-# LANGUAGE DeriveDataTypeable #-} 5 | {-# LANGUAGE EmptyDataDecls #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | module Data.Logic.ATP.Lit 16 | ( IsLiteral(naiveNegate, foldNegation, foldLiteral') 17 | , (.~.), (¬), negate 18 | , negated 19 | , negative, positive 20 | , foldLiteral 21 | , JustLiteral 22 | , onatomsLiteral 23 | , overatomsLiteral 24 | , zipLiterals', zipLiterals 25 | , convertLiteral 26 | , convertToLiteral 27 | , precedenceLiteral 28 | , associativityLiteral 29 | , prettyLiteral 30 | , showLiteral 31 | -- * Instance 32 | , LFormula(T, F, Atom, Not) 33 | , Lit(L, lname) 34 | ) where 35 | 36 | import Data.Data (Data) 37 | import Data.Logic.ATP.Formulas (IsAtom, IsFormula(atomic, AtomOf, asBool, false, true), fromBool, overatoms, onatoms, prettyBool) 38 | import Data.Logic.ATP.Pretty (Associativity(..), boolPrec, Doc, HasFixity(precedence, associativity), notPrec, Precedence, text) 39 | import Data.Monoid ((<>)) 40 | import Data.Typeable (Typeable) 41 | import Prelude hiding (negate, null) 42 | import Text.PrettyPrint.HughesPJClass (maybeParens, Pretty(pPrint, pPrintPrec), PrettyLevel, prettyNormal) 43 | 44 | -- | The class of formulas that can be negated. Literals are the 45 | -- building blocks of the clause and implicative normal forms. They 46 | -- support negation and must include true and false elements. 47 | class IsFormula lit => IsLiteral lit where 48 | -- | Negate a formula in a naive fashion, the operators below 49 | -- prevent double negation. 50 | naiveNegate :: lit -> lit 51 | -- | Test whether a lit is negated or normal 52 | foldNegation :: (lit -> r) -- ^ called for normal formulas 53 | -> (lit -> r) -- ^ called for negated formulas 54 | -> lit -> r 55 | -- | This is the internal fold for literals, 'foldLiteral' below should 56 | -- normally be used, but its argument must be an instance of 'JustLiteral'. 57 | foldLiteral' :: (lit -> r) -- ^ Called for higher order formulas (non-literal) 58 | -> (lit -> r) -- ^ Called for negated formulas 59 | -> (Bool -> r) -- ^ Called for true and false formulas 60 | -> (AtomOf lit -> r) -- ^ Called for atomic formulas 61 | -> lit -> r 62 | 63 | -- | Is this formula negated at the top level? 64 | negated :: IsLiteral formula => formula -> Bool 65 | negated = foldNegation (const False) (not . negated) 66 | 67 | -- | Negate the formula, avoiding double negation 68 | (.~.), (¬), negate :: IsLiteral formula => formula -> formula 69 | (.~.) = foldNegation naiveNegate id 70 | (¬) = (.~.) 71 | negate = (.~.) 72 | infix 6 .~., ¬ 73 | 74 | -- | Some operations on IsLiteral formulas 75 | negative :: IsLiteral formula => formula -> Bool 76 | negative = negated 77 | 78 | positive :: IsLiteral formula => formula -> Bool 79 | positive = not . negative 80 | 81 | foldLiteral :: JustLiteral lit => (lit -> r) -> (Bool -> r) -> (AtomOf lit -> r) -> lit -> r 82 | foldLiteral = foldLiteral' (error "JustLiteral failure") 83 | 84 | -- | Class that indicates that a formula type *only* contains 'IsLiteral' 85 | -- features - no combinations or quantifiers. 86 | class IsLiteral formula => JustLiteral formula 87 | 88 | -- | Combine two literals (internal version). 89 | zipLiterals' :: (IsLiteral lit1, IsLiteral lit2) => 90 | (lit1 -> lit2 -> Maybe r) 91 | -> (lit1 -> lit2 -> Maybe r) 92 | -> (Bool -> Bool -> Maybe r) 93 | -> (AtomOf lit1 -> AtomOf lit2 -> Maybe r) 94 | -> lit1 -> lit2 -> Maybe r 95 | zipLiterals' ho neg tf at fm1 fm2 = 96 | foldLiteral' ho' neg' tf' at' fm1 97 | where 98 | ho' x1 = foldLiteral' (ho x1) (\ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) fm2 99 | neg' p1 = foldLiteral' (\ _ -> Nothing) (neg p1) (\ _ -> Nothing) (\ _ -> Nothing) fm2 100 | tf' x1 = foldLiteral' (\ _ -> Nothing) (\ _ -> Nothing) (tf x1) (\ _ -> Nothing) fm2 101 | at' a1 = foldLiteral' (\ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) (at a1) fm2 102 | 103 | -- | Combine two literals. 104 | zipLiterals :: (JustLiteral lit1, JustLiteral lit2) => 105 | (lit1 -> lit2 -> Maybe r) 106 | -> (Bool -> Bool -> Maybe r) 107 | -> (AtomOf lit1 -> AtomOf lit2 -> Maybe r) 108 | -> lit1 -> lit2 -> Maybe r 109 | zipLiterals neg tf at fm1 fm2 = 110 | foldLiteral neg' tf' at' fm1 111 | where 112 | neg' p1 = foldLiteral (neg p1) (\ _ -> Nothing) (\ _ -> Nothing) fm2 113 | tf' x1 = foldLiteral (\ _ -> Nothing) (tf x1) (\ _ -> Nothing) fm2 114 | at' a1 = foldLiteral (\ _ -> Nothing) (\ _ -> Nothing) (at a1) fm2 115 | 116 | -- | Convert a 'JustLiteral' instance to any 'IsLiteral' instance. 117 | convertLiteral :: (JustLiteral lit1, IsLiteral lit2) => (AtomOf lit1 -> AtomOf lit2) -> lit1 -> lit2 118 | convertLiteral ca fm = foldLiteral (\fm' -> (.~.) (convertLiteral ca fm')) fromBool (atomic . ca) fm 119 | 120 | -- | Convert any formula to a literal, passing non-IsLiteral 121 | -- structures to the first argument (typically a call to error.) 122 | convertToLiteral :: (IsLiteral formula, JustLiteral lit) => 123 | (formula -> lit) -> (AtomOf formula -> AtomOf lit) -> formula -> lit 124 | convertToLiteral ho ca fm = foldLiteral' ho (\fm' -> (.~.) (convertToLiteral ho ca fm')) fromBool (atomic . ca) fm 125 | 126 | precedenceLiteral :: JustLiteral lit => lit -> Precedence 127 | precedenceLiteral = foldLiteral (const notPrec) (const boolPrec) precedence 128 | associativityLiteral :: JustLiteral lit => lit -> Associativity 129 | associativityLiteral = foldLiteral (const InfixA) (const InfixN) associativity 130 | 131 | -- | Implementation of 'pPrint' for -- 'JustLiteral' types. 132 | prettyLiteral :: JustLiteral lit => PrettyLevel -> Rational -> lit -> Doc 133 | prettyLiteral l r lit = 134 | maybeParens (l > prettyNormal || r > precedence lit) (foldLiteral ne tf at lit) 135 | where 136 | ne p = text "¬" <> prettyLiteral l (precedence lit) p 137 | tf = prettyBool 138 | at a = pPrint a 139 | 140 | showLiteral :: JustLiteral lit => lit -> String 141 | showLiteral lit = foldLiteral ne tf at lit 142 | where 143 | ne p = "(.~.)(" ++ showLiteral p ++ ")" 144 | tf = show 145 | at = show 146 | 147 | -- | Implementation of 'onatoms' for 'JustLiteral' types. 148 | onatomsLiteral :: JustLiteral lit => (AtomOf lit -> AtomOf lit) -> lit -> lit 149 | onatomsLiteral f fm = 150 | foldLiteral ne tf at fm 151 | where 152 | ne p = (.~.) (onatomsLiteral f p) 153 | tf = fromBool 154 | at x = atomic (f x) 155 | 156 | -- | implementation of 'overatoms' for 'JustLiteral' types. 157 | overatomsLiteral :: JustLiteral lit => (AtomOf lit -> r -> r) -> lit -> r -> r 158 | overatomsLiteral f fm r0 = 159 | foldLiteral ne (const r0) (flip f r0) fm 160 | where 161 | ne fm' = overatomsLiteral f fm' r0 162 | 163 | -- | Example of a 'JustLiteral' type. 164 | data LFormula atom 165 | = F 166 | | T 167 | | Atom atom 168 | | Not (LFormula atom) 169 | deriving (Eq, Ord, Read, Show, Data, Typeable) 170 | 171 | data Lit = L {lname :: String} deriving (Eq, Ord) 172 | 173 | instance IsAtom atom => IsFormula (LFormula atom) where 174 | type AtomOf (LFormula atom) = atom 175 | asBool T = Just True 176 | asBool F = Just False 177 | asBool _ = Nothing 178 | true = T 179 | false = F 180 | atomic = Atom 181 | overatoms = overatomsLiteral 182 | onatoms = onatomsLiteral 183 | 184 | instance (IsFormula (LFormula atom), Eq atom, Ord atom) => IsLiteral (LFormula atom) where 185 | naiveNegate = Not 186 | foldNegation normal inverted (Not x) = foldNegation inverted normal x 187 | foldNegation normal _ x = normal x 188 | foldLiteral' _ ne tf at lit = 189 | case lit of 190 | F -> tf False 191 | T -> tf True 192 | Atom a -> at a 193 | Not f -> ne f 194 | 195 | instance IsAtom atom => JustLiteral (LFormula atom) 196 | 197 | instance IsAtom atom => HasFixity (LFormula atom) where 198 | precedence = precedenceLiteral 199 | associativity = associativityLiteral 200 | 201 | instance IsAtom atom => Pretty (LFormula atom) where 202 | pPrintPrec = prettyLiteral 203 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/LitWrapper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} 2 | module Data.Logic.ATP.LitWrapper 3 | ( JL(unJL) 4 | ) where 5 | 6 | import Data.Logic.ATP.Formulas 7 | import Data.Logic.ATP.Lit 8 | import Data.Logic.ATP.Pretty 9 | 10 | -- | Wrapper type to make an IsLiteral value that happens to also be 11 | -- JustLiteral. The JL constructor is not exported, JL values can be 12 | -- built using 'convertToLiteral'. 13 | newtype JL a = JL {unJL :: a} 14 | 15 | instance Pretty a => Pretty (JL a) where 16 | pPrint (JL x) = pPrint x 17 | 18 | instance HasFixity a => HasFixity (JL a) where 19 | precedence = precedence . unJL 20 | associativity = associativity . unJL 21 | 22 | instance IsLiteral a => IsFormula (JL a) where 23 | type AtomOf (JL a) = AtomOf a 24 | asBool (JL x) = asBool x 25 | true = JL (true :: a) 26 | false = JL (false :: a) 27 | atomic = JL . atomic 28 | overatoms f (JL x) r0 = overatomsLiteral' {-(\y r -> f (JL y) r)-} f x r0 29 | onatoms f (JL x) = JL (onatoms f x) 30 | 31 | instance (IsFormula (JL a), IsLiteral a) => JustLiteral (JL a) 32 | 33 | instance (IsFormula (JL a), IsLiteral a) => IsLiteral (JL a) where 34 | naiveNegate (JL x) = JL (naiveNegate x) 35 | foldNegation n i (JL x) = foldNegation (n . JL) (i . JL) x 36 | foldLiteral' ho ne tf at (JL x) = foldLiteral' (ho . JL) (ne . JL) tf at x 37 | 38 | -- | Unsafe local version of overatomsLiteral - assumes lit is a JustLiteral. 39 | overatomsLiteral' :: IsLiteral lit => (AtomOf lit -> r -> r) -> lit -> r -> r 40 | overatomsLiteral' f fm r0 = 41 | foldLiteral' undefined ne (const r0) (flip f r0) fm 42 | where 43 | ne fm' = overatomsLiteral' f fm' r0 44 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, NoMonomorphismRestriction, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, TemplateHaskell, TypeFamilies #-} 2 | module Data.Logic.ATP.Parser where 3 | 4 | -- Parsing expressions and statements 5 | -- https://wiki.haskell.org/Parsing_expressions_and_statements 6 | 7 | import Control.Monad.Identity 8 | import Data.Char (isSpace) 9 | import Data.List (nub) 10 | import Data.String (fromString) 11 | import Language.Haskell.TH.Quote (QuasiQuoter(..)) 12 | import Text.Parsec 13 | import Text.Parsec.Error 14 | import Text.Parsec.Expr 15 | import Text.Parsec.Token 16 | import Text.Parsec.Language 17 | import Text.PrettyPrint.HughesPJClass (Pretty(pPrint), text) 18 | 19 | import Data.Logic.ATP.Apply 20 | import Data.Logic.ATP.Equate 21 | import Data.Logic.ATP.Formulas 22 | import Data.Logic.ATP.Lit 23 | import Data.Logic.ATP.Prop 24 | import Data.Logic.ATP.Quantified 25 | import Data.Logic.ATP.Skolem 26 | import Data.Logic.ATP.Term 27 | 28 | instance Pretty ParseError where 29 | pPrint = text . show 30 | 31 | instance Pretty Message where 32 | pPrint (SysUnExpect s) = text ("SysUnExpect " ++ show s) 33 | pPrint (UnExpect s) = text ("UnExpect " ++ show s) 34 | pPrint (Expect s) = text ("Expect " ++ show s) 35 | pPrint (Message s) = text ("Message " ++ show s) 36 | 37 | -- | QuasiQuote for a first order formula. Loading this symbol into the interpreter 38 | -- and setting -XQuasiQuotes lets you type expressions like [fof| ∃ x. p(x) |] 39 | fof :: QuasiQuoter 40 | fof = QuasiQuoter 41 | { quoteExp = \str -> [| (either (error . show) id . parseFOL) str :: Formula |] 42 | , quoteType = error "fof does not implement quoteType" 43 | , quotePat = error "fof does not implement quotePat" 44 | , quoteDec = error "fof does not implement quoteDec" 45 | } 46 | 47 | -- | QuasiQuote for a propositional formula. Exactly like fof, but no quantifiers. 48 | pf :: QuasiQuoter 49 | pf = QuasiQuoter 50 | { quoteExp = \str -> [| (either (error . show) id . parsePL) str :: PFormula EqAtom |] 51 | , quoteType = error "pf does not implement quoteType" 52 | , quotePat = error "pf does not implement quotePat" 53 | , quoteDec = error "pf does not implement quoteDec" 54 | } 55 | 56 | -- | QuasiQuote for a propositional formula. Exactly like fof, but no quantifiers. 57 | lit :: QuasiQuoter 58 | lit = QuasiQuoter 59 | { quoteExp = \str -> [| (either (error . show) id . parseLit) str :: LFormula EqAtom |] 60 | , quoteType = error "pf does not implement quoteType" 61 | , quotePat = error "pf does not implement quotePat" 62 | , quoteDec = error "pf does not implement quoteDec" 63 | } 64 | 65 | -- | QuasiQuote for a propositional formula. Exactly like fof, but no quantifiers. 66 | term :: QuasiQuoter 67 | term = QuasiQuoter 68 | { quoteExp = \str -> [| (either (error . show) id . parseFOLTerm) str :: FTerm |] 69 | , quoteType = error "term does not implement quoteType" 70 | , quotePat = error "term does not implement quotePat" 71 | , quoteDec = error "term does not implement quoteDec" 72 | } 73 | 74 | #if 0 75 | instance Read PrologRule where 76 | readsPrec _n str = [(parseProlog str,"")] 77 | 78 | instance Read Formula where 79 | readsPrec _n str = [(parseFOL str,"")] 80 | 81 | instance Read (PFormula EqAtom) where 82 | readsPrec _n str = [(parsePL str,"")] 83 | 84 | parseProlog :: forall s. Stream s Identity Char => s -> PrologRule 85 | parseProlog str = either (error . show) id $ parse prologparser "" str 86 | #endif 87 | parseFOL :: Stream String Identity Char => String -> Either ParseError Formula 88 | parseFOL str = parse folparser "" (dropWhile isSpace str) 89 | parsePL :: Stream String Identity Char => String -> Either ParseError (PFormula EqAtom) 90 | parsePL str = parse propparser "" (dropWhile isSpace str) 91 | parseLit :: Stream String Identity Char => String -> Either ParseError (LFormula EqAtom) 92 | parseLit str = parse litparser "" (dropWhile isSpace str) 93 | parseFOLTerm :: Stream String Identity Char => String -> Either ParseError FTerm 94 | parseFOLTerm str = parse folsubterm "" (dropWhile isSpace str) 95 | 96 | def :: forall s u m. Stream s m Char => GenLanguageDef s u m 97 | def = emptyDef{ identStart = letter 98 | , identLetter = alphaNum <|> oneOf "'" 99 | , opStart = oneOf (nub (map head allOps)) 100 | , opLetter = oneOf (nub (concat (map tail allOps))) 101 | , reservedOpNames = allOps 102 | , reservedNames = allIds 103 | } 104 | 105 | m_parens :: forall t t1 t2. Stream t t2 Char => forall a. ParsecT t t1 t2 a -> ParsecT t t1 t2 a 106 | m_angles :: forall t t1 t2. Stream t t2 Char => forall a. ParsecT t t1 t2 a -> ParsecT t t1 t2 a 107 | m_symbol :: forall t t1 t2. Stream t t2 Char => String -> ParsecT t t1 t2 String 108 | m_integer :: forall t t1 t2. Stream t t2 Char => ParsecT t t1 t2 Integer 109 | m_identifier :: forall t t1 t2. Stream t t2 Char => ParsecT t t1 t2 String 110 | m_reservedOp :: forall t t1 t2. Stream t t2 Char => String -> ParsecT t t1 t2 () 111 | m_reserved :: forall t t1 t2. Stream t t2 Char => String -> ParsecT t t1 t2 () 112 | m_whiteSpace :: forall t t1 t2. Stream t t2 Char => ParsecT t t1 t2 () 113 | TokenParser{ parens = m_parens 114 | , angles = m_angles 115 | -- , brackets = m_brackets 116 | , symbol = m_symbol 117 | , integer = m_integer 118 | , identifier = m_identifier 119 | , reservedOp = m_reservedOp 120 | , reserved = m_reserved 121 | -- , semiSep1 = m_semiSep1 122 | , whiteSpace = m_whiteSpace } = makeTokenParser def 123 | 124 | #if 0 125 | prologparser :: forall s u m. Stream s m Char => ParsecT s u m PrologRule 126 | prologparser = try (do 127 | left <- folparser 128 | m_symbol ":-" 129 | right <- sepBy folparser (m_symbol ",") 130 | return (Prolog right left)) 131 | <|> (do 132 | left <- folparser 133 | return (Prolog [] left)) 134 | "prolog expression" 135 | #endif 136 | 137 | litparser :: forall formula s u m. (JustLiteral formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula 138 | litparser = litexprparser litterm 139 | propparser :: forall formula s u m. (JustPropositional formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula 140 | propparser = propexprparser propterm 141 | folparser :: forall formula s u m. (IsQuantified formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula 142 | folparser = propexprparser folterm 143 | 144 | litexprparser :: forall formula s u m. (IsLiteral formula, Stream s m Char) => ParsecT s u m formula -> ParsecT s u m formula 145 | litexprparser trm = buildExpressionParser table trm "lit" 146 | where 147 | table = [ [Prefix (m_reservedOp "~" >> return (.~.))] 148 | ] 149 | 150 | propexprparser :: forall formula s u m. (IsPropositional formula, Stream s m Char) => ParsecT s u m formula -> ParsecT s u m formula 151 | propexprparser trm = buildExpressionParser table trm "prop" 152 | where 153 | table = [ map (\op -> Prefix (m_reservedOp op >> return (.~.))) notOps 154 | , map (\op -> Infix (m_reservedOp op >> return (.&.)) AssocRight) andOps -- should these be assocLeft? 155 | , map (\op -> Infix (m_reservedOp op >> return (.|.)) AssocRight) orOps 156 | , map (\op -> Infix (m_reservedOp op >> return (.=>.)) AssocRight) impOps 157 | , map (\op -> Infix (m_reservedOp op >> return (.<=>.)) AssocRight) iffOps 158 | ] 159 | 160 | litterm :: forall formula s u m. (JustLiteral formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula 161 | litterm = try (m_parens litparser) 162 | <|> try folpredicate_infix 163 | <|> folpredicate 164 | <|> foldr1 (<|>) (map (\s -> m_reserved s >> return true) trueIds ++ map (\s -> m_reservedOp s >> return true) trueOps) 165 | <|> foldr1 (<|>) (map (\s -> m_reserved s >> return false) falseIds ++ map (\s -> m_reservedOp s >> return false) falseOps) 166 | 167 | propterm :: forall formula s u m. (JustPropositional formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula 168 | propterm = try (m_parens propparser) 169 | <|> try folpredicate_infix 170 | <|> folpredicate 171 | <|> foldr1 (<|>) (map (\s -> m_reserved s >> return true) trueIds ++ map (\s -> m_reservedOp s >> return true) trueOps) 172 | <|> foldr1 (<|>) (map (\s -> m_reserved s >> return false) falseIds ++ map (\s -> m_reservedOp s >> return false) falseOps) 173 | 174 | folterm :: forall formula s u m. (IsQuantified formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula 175 | folterm = try (m_parens folparser) 176 | <|> try folpredicate_infix 177 | <|> folpredicate 178 | <|> existentialQuantifier 179 | <|> forallQuantifier 180 | <|> foldr1 (<|>) (map (\s -> m_reserved s >> return true) trueIds ++ map (\s -> m_reservedOp s >> return true) trueOps) 181 | <|> foldr1 (<|>) (map (\s -> m_reserved s >> return false) falseIds ++ map (\s -> m_reservedOp s >> return false) falseOps) 182 | 183 | existentialQuantifier :: forall formula s u m. (IsQuantified formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula 184 | existentialQuantifier = foldr1 (<|>) (map (\ s -> quantifierId s (exists . fromString)) existsIds ++ map (\ s -> quantifierOp s (exists . fromString)) existsOps) 185 | forallQuantifier :: forall formula s u m. (IsQuantified formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula 186 | forallQuantifier = foldr1 (<|>) (map (\ s -> quantifierId s (for_all . fromString)) forallIds ++ map (\ s -> quantifierOp s (for_all . fromString)) forallOps) 187 | 188 | quantifierId :: forall formula s u m. (IsQuantified formula, HasEquate (AtomOf formula), Stream s m Char) => 189 | String -> (String -> formula -> formula) -> ParsecT s u m formula 190 | quantifierId name op = do 191 | m_reserved name 192 | is <- many1 m_identifier 193 | _ <- m_symbol "." 194 | fm <- folparser 195 | return (foldr op fm is) 196 | 197 | quantifierOp :: forall formula s u m. (IsQuantified formula, HasEquate (AtomOf formula), Stream s m Char) => 198 | String -> (String -> formula -> formula) -> ParsecT s u m formula 199 | quantifierOp name op = do 200 | m_reservedOp name 201 | is <- many1 m_identifier 202 | _ <- m_symbol "." 203 | fm <- folparser 204 | return (foldr op fm is) 205 | 206 | folpredicate_infix :: forall formula s u m. (IsFormula formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula 207 | folpredicate_infix = choice (map (try . app) predicate_infix_symbols) 208 | where 209 | app op = do 210 | x <- folsubterm 211 | m_reservedOp op 212 | y <- folsubterm 213 | return (if elem op equateOps then x .=. y else pApp (fromString op) [x, y]) 214 | 215 | folpredicate :: forall formula s u m. (IsFormula formula, HasEquate (AtomOf formula), Stream s m Char) => ParsecT s u m formula 216 | folpredicate = do 217 | p <- m_identifier <|> m_symbol "|--" 218 | xs <- option [] (m_parens (sepBy1 folsubterm (m_symbol ","))) 219 | return (pApp (fromString p) xs) 220 | 221 | folfunction :: forall term s u m. (IsTerm term, Stream s m Char) => ParsecT s u m term 222 | folfunction = do 223 | fname <- m_identifier 224 | xs <- m_parens (sepBy1 folsubterm (m_symbol ",")) 225 | return (fApp (fromString fname) xs) 226 | 227 | folconstant_numeric :: forall term t t1 t2. (IsTerm term, Stream t t2 Char) => ParsecT t t1 t2 term 228 | folconstant_numeric = do 229 | i <- m_integer 230 | return (fApp (fromString . show $ i) []) 231 | 232 | folconstant_reserved :: forall term t t1 t2. (IsTerm term, Stream t t2 Char) => String -> ParsecT t t1 t2 term 233 | folconstant_reserved str = do 234 | m_reserved str 235 | return (fApp (fromString str) []) 236 | 237 | folconstant :: forall term t t1 t2. (IsTerm term, Stream t t2 Char) => ParsecT t t1 t2 term 238 | folconstant = do 239 | name <- m_angles m_identifier 240 | return (fApp (fromString name) []) 241 | 242 | folsubterm :: forall term s u m. (IsTerm term, Stream s m Char) => ParsecT s u m term 243 | folsubterm = folfunction_infix <|> folsubterm_prefix 244 | 245 | folsubterm_prefix :: forall term s u m. (IsTerm term, Stream s m Char) => ParsecT s u m term 246 | folsubterm_prefix = 247 | m_parens folfunction_infix 248 | <|> try folfunction 249 | <|> choice (map folconstant_reserved constants) 250 | <|> folconstant_numeric 251 | <|> folconstant 252 | <|> (fmap (vt . fromString) m_identifier) 253 | 254 | folfunction_infix :: forall term s u m. (IsTerm term, Stream s m Char) => ParsecT s u m term 255 | folfunction_infix = buildExpressionParser table folsubterm_prefix "fof" 256 | where 257 | table = [ [Infix (m_reservedOp "::" >> return (\x y -> fApp (fromString "::") [x,y])) AssocRight] 258 | , [Infix (m_reservedOp "*" >> return (\x y -> fApp (fromString "*") [x,y])) AssocLeft, Infix (m_reservedOp "/" >> return (\x y -> fApp (fromString "/") [x,y])) AssocLeft] 259 | , [Infix (m_reservedOp "+" >> return (\x y -> fApp (fromString "+") [x,y])) AssocLeft, Infix (m_reservedOp "-" >> return (\x y -> fApp (fromString "-") [x,y])) AssocLeft] 260 | ] 261 | 262 | allOps :: [String] 263 | allOps = notOps ++ trueOps ++ falseOps ++ andOps ++ orOps ++ impOps ++ iffOps ++ 264 | forallOps ++ existsOps ++ equateOps ++ provesOps ++ entailsOps ++ predicate_infix_symbols 265 | 266 | allIds :: [String] 267 | allIds = trueIds ++ falseIds ++ existsIds ++ forallIds ++ constants 268 | 269 | predicate_infix_symbols :: [String] 270 | predicate_infix_symbols = equateOps ++ ["<",">","<=",">="] 271 | 272 | constants :: [[Char]] 273 | constants = ["nil"] 274 | 275 | equateOps = ["=", ".=."] 276 | provesOps = ["⊢", "|--"] 277 | entailsOps = ["⊨", "|=="] 278 | 279 | notOps :: [String] 280 | notOps = ["¬", "~", ".~."] 281 | 282 | trueOps, trueIds, falseOps, falseIds, provesOps, entailsOps, equateOps :: [String] 283 | trueOps = ["⊤"] 284 | trueIds = ["True", "true"] 285 | falseOps = ["⊥"] 286 | falseIds = ["False", "false"] 287 | 288 | andOps, orOps, impOps, iffOps :: [String] 289 | andOps = [".&.", "&", "∧", "⋀", "/\\", "·"] 290 | orOps = ["|", "∨", "⋁", "+", ".|.", "\\/"] 291 | impOps = ["==>", "⇒", "⟹", ".=>.", "→", "⊃"] 292 | iffOps = ["<==>", "⇔", ".<=>.", "↔"] 293 | 294 | forallIds, forallOps, existsIds, existsOps :: [String] 295 | forallIds = ["forall", "for_all"] 296 | forallOps= ["∀"] 297 | existsIds = ["exists"] 298 | existsOps = ["∃"] 299 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/ParserTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, QuasiQuotes, RankNTypes, ScopedTypeVariables, TemplateHaskell #-} 2 | module Data.Logic.ATP.ParserTests where 3 | 4 | import Data.Logic.ATP.Equate ((.=.)) 5 | import Data.Logic.ATP.Pretty (assertEqual', Pretty(..), prettyShow, testEquals) 6 | import Data.Logic.ATP.Prop ((.&.), (.=>.)) 7 | import Data.Logic.ATP.Parser (fof, parseFOL) 8 | import Data.Logic.ATP.Skolem (Formula) 9 | import Test.HUnit 10 | 11 | t :: (Eq a, Pretty a) => String -> a -> a -> Test 12 | t label expected actual = TestLabel label (TestCase (assertEqual' label expected actual)) 13 | 14 | parseFOL' :: String -> Either String Formula 15 | parseFOL' = either (Left . show) Right . parseFOL 16 | 17 | testParser :: Test 18 | testParser = 19 | -- I would like these Lefts to work 20 | TestLabel "ParserTests" 21 | (TestList [ $(testEquals "precedence 1a") (Right [fof| (∃x. ⊤∧(∃y. ⊤)) |]) 22 | (parseFOL' " ∃x. (true & (∃y. true)) ") 23 | , $(testEquals "precedence 1b") (Right [fof| ∃x. (true & (∃y. true)) |]) 24 | (parseFOL " ∃x. (true & (∃y. true)) ") 25 | , $(testEquals "precedence 1c") (Right [fof|(∃x. ⊤∧(∃y. ⊤))|]) 26 | (parseFOL' " ∃x. true & ∃y. true ") 27 | , $(testEquals "precedence 2") [fof| (true & false) | true |] 28 | [fof| true & false | true |] 29 | , $(testEquals "precedence 3") [fof| (true | false) <==> true |] 30 | [fof| true | false <==> true |] 31 | , $(testEquals "precedence 4") [fof| true <==> (false ==> true) |] 32 | [fof| true <==> false ==> true |] 33 | , $(testEquals "precedence 5") [fof| (~ true) & false |] 34 | [fof| ~ true & false |] 35 | -- repeated prefix operator with same precedences fails: 36 | , $(testEquals "precedence 6") (Right [fof|(∃x y. (x=y))|]) 37 | (parseFOL' " ∃x. ∃y. x=y ") 38 | , $(testEquals "precedence 6b") [fof|(∃x. (∃y. (x=y)))|] 39 | [fof| ∃x. (∃y. x=y) |] 40 | , $(testEquals "precedence 7") [fof| ∃x. (∃y. (x=y)) |] 41 | [fof| ∃x y. x=y |] 42 | , $(testEquals "precedence 8") [fof| ∀x. (∃y. (x=y)) |] 43 | [fof| ∀x. ∃y. x=y |] 44 | , $(testEquals "precedence 9") [fof| ∃y. (∀x. (x=y)) |] 45 | [fof| ∃y. (∀x. x=y) |] 46 | , $(testEquals "precedence 10") [fof| (~P) & Q |] 47 | [fof| ~P & Q |] -- ~ vs & 48 | -- repeated prefix operator with same precedences fails: 49 | , $(testEquals "precedence 10a") (Left "(line 1, column 3):\nunexpected '~'\nexpecting prop") 50 | (parseFOL' " ~~P ") 51 | , $(testEquals "precedence 11") [fof| (P & Q) | R |] 52 | [fof| P & Q | R |] -- & vs | 53 | , $(testEquals "precedence 12") [fof| (P | Q) ==> R |] 54 | [fof| P | Q ==> R |] -- or vs imp 55 | , $(testEquals "precedence 13") [fof| (P ==> Q) <==> R |] 56 | [fof| P ==> Q <==> R |] -- imp vs iff 57 | -- , TestCase "precedence 14" [fof| ∃x. (∀y. x=y) |] [fof| ∃x. ∀y. x=y |] 58 | , $(testEquals "precedence 14a") [fof| ((x = y) ∧ (x = z)) ⇒ (y = z) |] 59 | ("x" .=. "y" .&. "x" .=. "z" .=>. "y" .=. "z") 60 | , $(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)))" 61 | (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)))) |]) 62 | , $(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')) |] 63 | [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'))) |] 64 | -- We could use haskell-src-meta to perform the third 65 | -- step of the round trip, roughly 66 | -- 67 | -- 1. formula string to parsed formula expression (Parser.parseExp) 68 | -- 2. formula expression to parsed haskell-src-exts expression (show and th-lift?) 69 | -- 3. haskell-src-exts to template-haskell expression (the toExp method of haskell-src-meta) 70 | -- 4. template haskell back to haskell expression (template-haskell unquote) 71 | {- 72 | , $(testEquals "read 1") (show (ParseOk (InfixApp (App 73 | (App (Var (UnQual (Ident "for_all"))) (Lit (String "x"))) 74 | (Paren (Lit (String "x")))) (QVarOp (UnQual (Symbol ".=."))) (Paren (Lit (String "x")))))) 75 | (show (parseExp (show [fof| ∀x. (x=x) |]))) 76 | , $(testEquals "read 2") (show (ParseOk (InfixApp (App (App (App (App (Var (UnQual (Ident "for_all"))) (Lit (String "x"))) 77 | (Var (UnQual (Ident "pApp")))) 78 | (Paren (App (Var (UnQual (Ident "fromString"))) (Lit (String "P"))))) 79 | (List [Lit (String "x")])) 80 | (QVarOp (UnQual (Symbol ".&."))) 81 | (App (App (Var (UnQual (Ident "pApp"))) 82 | (Paren (App (Var (UnQual (Ident "fromString"))) 83 | (Lit (String "Q"))))) 84 | (List [Lit (String "x")]))))) 85 | (show (parseExp (show [fof| ∀x. P(x) ∧ Q(x) |]))) 86 | -} 87 | , $(testEquals "parse 1") [fof| (forall x. i(x) * x = 1) ==> (forall x. i(x) * x = 1) |] 88 | [fof| (forall x. i(x) * x = 1) ==> forall x. i(x) * x = 1 |] 89 | , $(testEquals "parse 2") "(*(i(x), x))=(1)" -- "i(x) * x = 1" 90 | (prettyShow [fof| (i(x) * x = 1) |]) 91 | , $(testEquals "parse 3") [fof| ⊤⇒(∀x. ⊤) |] 92 | [fof| true ==> forall x. true |] 93 | , $(testEquals "parse 4") "⊤" 94 | (prettyShow [fof| true |]) 95 | , $(testEquals "parse 5") "⊥" 96 | (prettyShow [fof| false |]) 97 | ]) 98 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE EmptyDataDecls #-} 4 | {-# LANGUAGE ImplicitParams #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TypeSynonymInstances #-} 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | module Data.Logic.ATP.Pretty 14 | ( (<>) 15 | , Pretty(pPrint, pPrintPrec) 16 | , module Text.PrettyPrint.HughesPJClass 17 | , Associativity(InfixL, InfixR, InfixN, InfixA) 18 | , Precedence 19 | , HasFixity(precedence, associativity) 20 | , Side(Top, LHS, RHS, Unary) 21 | , testParen 22 | -- , parenthesize 23 | , assertEqual' 24 | , testEquals 25 | , leafPrec 26 | , boolPrec 27 | , notPrec 28 | , atomPrec 29 | , andPrec 30 | , orPrec 31 | , impPrec 32 | , iffPrec 33 | , quantPrec 34 | , eqPrec 35 | , pAppPrec 36 | ) where 37 | 38 | import Control.Monad (unless) 39 | import Data.Map.Strict as Map (Map, toList) 40 | import Data.Monoid ((<>)) 41 | import Data.Set as Set (Set, toAscList) 42 | import GHC.Stack 43 | import Language.Haskell.TH (ExpQ, litE, stringL) 44 | import Test.HUnit (Assertion, assertFailure, Test(TestLabel, TestCase)) 45 | import Text.PrettyPrint.HughesPJClass (brackets, comma, Doc, fsep, hcat, nest, Pretty(pPrint, pPrintPrec), prettyShow, punctuate, text) 46 | 47 | -- | A class to extract the fixity of a formula so they can be 48 | -- properly parenthesized. 49 | -- 50 | -- The Haskell FixityDirection type is concerned with how to interpret 51 | -- a formula formatted in a certain way, but here we are concerned 52 | -- with how to format a formula given its interpretation. As such, 53 | -- one case the Haskell type does not capture is whether the operator 54 | -- follows the associative law, so we can omit parentheses in an 55 | -- expression such as @a & b & c@. Hopefully, we can generate 56 | -- formulas so that an associative operator with left associative 57 | -- fixity direction appears as (a+b)+c rather than a+(b+c). 58 | class HasFixity x where 59 | precedence :: x -> Precedence 60 | precedence _ = leafPrec 61 | associativity :: x -> Associativity 62 | associativity _ = InfixL 63 | 64 | -- | Use the same precedence type as the pretty package 65 | type Precedence = forall a. Num a => a 66 | 67 | data Associativity 68 | = InfixL -- Left-associative - a-b-c == (a-b)-c 69 | | InfixR -- Right-associative - a=>b=>c == a=>(b=>c) 70 | | InfixN -- Non-associative - a>b>c is an error 71 | | InfixA -- Associative - a+b+c == (a+b)+c == a+(b+c), ~~a == ~(~a) 72 | deriving Show 73 | 74 | -- | What side of the parent formula are we rendering? 75 | data Side = Top | LHS | RHS | Unary deriving Show 76 | 77 | -- | Decide whether to parenthesize based on which side of the parent binary 78 | -- operator we are rendering, the parent operator's precedence, and the precedence 79 | -- and associativity of the operator we are rendering. 80 | -- testParen :: Side -> Precedence -> Precedence -> Associativity -> Bool 81 | testParen :: (Eq a, Ord a, Num a) => Side -> a -> a -> Associativity -> Bool 82 | testParen side parentPrec childPrec childAssoc = 83 | testPrecedence || (parentPrec == childPrec && testAssoc) 84 | -- parentPrec > childPrec || (parentPrec == childPrec && testAssoc) 85 | where 86 | testPrecedence = 87 | parentPrec > childPrec || 88 | (parentPrec == orPrec && childPrec == andPrec) -- Special case - I can't keep these straight 89 | testAssoc = case (side, childAssoc) of 90 | (LHS, InfixL) -> False 91 | (RHS, InfixR) -> False 92 | (_, InfixA) -> False 93 | -- Tests from the previous version. 94 | -- (RHS, InfixL) -> True 95 | -- (LHS, InfixR) -> True 96 | -- (Unary, _) -> braces pp -- not sure 97 | -- (_, InfixN) -> error ("Nested non-associative operators: " ++ show pp) 98 | _ -> True 99 | 100 | instance Pretty a => Pretty (Set a) where 101 | pPrint = brackets . fsep . punctuate comma . map pPrint . Set.toAscList 102 | 103 | instance (Pretty v, Pretty term) => Pretty (Map v term) where 104 | pPrint = pPrint . Map.toList 105 | 106 | -- | Version of assertEqual that uses the pretty printer instead of show. 107 | assertEqual' :: ( 108 | #ifndef ghcjs_HOST_OS 109 | ?loc :: CallStack, 110 | #endif 111 | Eq a, Pretty a) => 112 | String -- ^ The message prefix 113 | -> a -- ^ The expected value 114 | -> a -- ^ The actual value 115 | -> Assertion 116 | assertEqual' preface expected actual = 117 | unless (actual == expected) (assertFailure msg) 118 | where msg = (if null preface then "" else preface ++ "\n") ++ 119 | "expected: " ++ prettyShow expected ++ "\n but got: " ++ prettyShow actual 120 | 121 | testEquals :: String -> ExpQ 122 | testEquals label = [| \expected actual -> TestLabel $(litE (stringL label)) $ TestCase $ assertEqual' $(litE (stringL label)) expected actual|] 123 | 124 | leafPrec :: Num a => a 125 | leafPrec = 9 126 | 127 | atomPrec :: Num a => a 128 | atomPrec = 7 129 | notPrec :: Num a => a 130 | notPrec = 6 131 | andPrec :: Num a => a 132 | andPrec = 5 133 | orPrec :: Num a => a 134 | orPrec = 4 135 | impPrec :: Num a => a 136 | impPrec = 3 137 | iffPrec :: Num a => a 138 | iffPrec = 2 139 | boolPrec :: Num a => a 140 | boolPrec = leafPrec 141 | quantPrec :: Num a => a 142 | quantPrec = 1 143 | eqPrec :: Num a => a 144 | eqPrec = 6 145 | pAppPrec :: Num a => a 146 | pAppPrec = 9 147 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/Prolog.hs: -------------------------------------------------------------------------------- 1 | -- | Backchaining procedure for Horn clauses, and toy Prolog implementation. 2 | 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# OPTIONS_GHC -Wall #-} 7 | 8 | module Data.Logic.ATP.Prolog where 9 | 10 | import Data.List as List (map) 11 | import Data.Logic.ATP.Apply (HasApply(TermOf)) 12 | import Data.Logic.ATP.FOL (var, lsubst) 13 | import Data.Logic.ATP.Formulas (IsFormula(AtomOf)) 14 | -- import Data.Logic.ATP.Lib (deepen) 15 | import Data.Logic.ATP.Lit (IsLiteral, JustLiteral) 16 | import Data.Logic.ATP.Term (IsTerm(TVarOf), vt) 17 | import Data.Map.Strict as Map 18 | import Data.Set as Set 19 | import Data.String (fromString) 20 | import Test.HUnit 21 | 22 | data PrologRule lit = Prolog (Set lit) lit deriving (Eq, Ord) 23 | 24 | -- ------------------------------------------------------------------------- 25 | -- Rename a rule. 26 | -- ------------------------------------------------------------------------- 27 | 28 | renamerule :: forall lit atom term v. 29 | (IsLiteral lit, JustLiteral lit, Ord lit, HasApply atom, IsTerm term, 30 | atom ~ AtomOf lit, term ~ TermOf atom, v ~ TVarOf term) => 31 | Int -> PrologRule lit -> (PrologRule lit, Int) 32 | renamerule k (Prolog asm c) = 33 | (Prolog (Set.map inst asm) (inst c), k + Set.size fvs) 34 | where 35 | fvs = Set.fold (Set.union . var) (Set.empty :: Set v) (Set.insert c asm) 36 | vvs = Map.fromList (List.map (\(v, i) -> (v, vt (fromString ("_" ++ show i)))) (zip (Set.toList fvs) [k..])) 37 | inst = lsubst vvs 38 | 39 | {- 40 | 41 | (* ------------------------------------------------------------------------- *) 42 | (* Basic prover for Horn clauses based on backchaining with unification. *) 43 | (* ------------------------------------------------------------------------- *) 44 | 45 | let rec backchain rules n k env goals = 46 | match goals with 47 | [] -> env 48 | | g::gs -> 49 | if n = 0 then failwith "Too deep" else 50 | tryfind (fun rule -> 51 | let (a,c),k' = renamerule k rule in 52 | backchain rules (n - 1) k' (unify_literals env (c,g)) (a @ gs)) 53 | rules;; 54 | 55 | let hornify cls = 56 | let pos,neg = partition positive cls in 57 | if length pos > 1 then failwith "non-Horn clause" 58 | else (map negate neg,if pos = [] then False else hd pos);; 59 | 60 | let hornprove fm = 61 | let rules = map hornify (simpcnf(skolemize(Not(generalize fm)))) in 62 | deepen (fun n -> backchain rules n 0 undefined [False],n) 0;; 63 | 64 | (* ------------------------------------------------------------------------- *) 65 | (* A Horn example. *) 66 | (* ------------------------------------------------------------------------- *) 67 | 68 | START_INTERACTIVE;; 69 | let p32 = hornprove 70 | <<(forall x. P(x) /\ (G(x) \/ H(x)) ==> Q(x)) /\ 71 | (forall x. Q(x) /\ H(x) ==> J(x)) /\ 72 | (forall x. R(x) ==> H(x)) 73 | ==> (forall x. P(x) /\ R(x) ==> J(x))>>;; 74 | 75 | (* ------------------------------------------------------------------------- *) 76 | (* A non-Horn example. *) 77 | (* ------------------------------------------------------------------------- *) 78 | 79 | (**************** 80 | 81 | hornprove <<(p \/ q) /\ (~p \/ q) /\ (p \/ ~q) ==> ~(~q \/ ~q)>>;; 82 | 83 | **********) 84 | END_INTERACTIVE;; 85 | 86 | (* ------------------------------------------------------------------------- *) 87 | (* Parsing rules in a Prolog-like syntax. *) 88 | (* ------------------------------------------------------------------------- *) 89 | 90 | let parserule s = 91 | let c,rest = 92 | parse_formula (parse_infix_atom,parse_atom) [] (lex(explode s)) in 93 | let asm,rest1 = 94 | if rest <> [] & hd rest = ":-" 95 | then parse_list "," 96 | (parse_formula (parse_infix_atom,parse_atom) []) (tl rest) 97 | else [],rest in 98 | if rest1 = [] then (asm,c) else failwith "Extra material after rule";; 99 | 100 | (* ------------------------------------------------------------------------- *) 101 | (* Prolog interpreter: just use depth-first search not iterative deepening. *) 102 | (* ------------------------------------------------------------------------- *) 103 | 104 | let simpleprolog rules gl = 105 | backchain (map parserule rules) (-1) 0 undefined [parse gl];; 106 | 107 | (* ------------------------------------------------------------------------- *) 108 | (* Ordering example. *) 109 | (* ------------------------------------------------------------------------- *) 110 | 111 | START_INTERACTIVE;; 112 | let lerules = ["0 <= X"; "S(X) <= S(Y) :- X <= Y"];; 113 | 114 | simpleprolog lerules "S(S(0)) <= S(S(S(0)))";; 115 | 116 | (*** simpleprolog lerules "S(S(0)) <= S(0)";; 117 | ***) 118 | 119 | let env = simpleprolog lerules "S(S(0)) <= X";; 120 | apply env "X";; 121 | END_INTERACTIVE;; 122 | 123 | (* ------------------------------------------------------------------------- *) 124 | (* With instantiation collection to produce a more readable result. *) 125 | (* ------------------------------------------------------------------------- *) 126 | 127 | let prolog rules gl = 128 | let i = solve(simpleprolog rules gl) in 129 | mapfilter (fun x -> Atom(R("=",[Var x; apply i x]))) (fv(parse gl));; 130 | 131 | (* ------------------------------------------------------------------------- *) 132 | (* Example again. *) 133 | (* ------------------------------------------------------------------------- *) 134 | 135 | START_INTERACTIVE;; 136 | prolog lerules "S(S(0)) <= X";; 137 | 138 | (* ------------------------------------------------------------------------- *) 139 | (* Append example, showing symmetry between inputs and outputs. *) 140 | (* ------------------------------------------------------------------------- *) 141 | 142 | let appendrules = 143 | ["append(nil,L,L)"; "append(H::T,L,H::A) :- append(T,L,A)"];; 144 | 145 | prolog appendrules "append(1::2::nil,3::4::nil,Z)";; 146 | 147 | prolog appendrules "append(1::2::nil,Y,1::2::3::4::nil)";; 148 | 149 | prolog appendrules "append(X,3::4::nil,1::2::3::4::nil)";; 150 | 151 | prolog appendrules "append(X,Y,1::2::3::4::nil)";; 152 | 153 | (* ------------------------------------------------------------------------- *) 154 | (* However this way round doesn't work. *) 155 | (* ------------------------------------------------------------------------- *) 156 | 157 | (*** 158 | *** prolog appendrules "append(X,3::4::nil,X)";; 159 | ***) 160 | 161 | (* ------------------------------------------------------------------------- *) 162 | (* A sorting example (from Lloyd's "Foundations of Logic Programming"). *) 163 | (* ------------------------------------------------------------------------- *) 164 | 165 | let sortrules = 166 | ["sort(X,Y) :- perm(X,Y),sorted(Y)"; 167 | "sorted(nil)"; 168 | "sorted(X::nil)"; 169 | "sorted(X::Y::Z) :- X <= Y, sorted(Y::Z)"; 170 | "perm(nil,nil)"; 171 | "perm(X::Y,U::V) :- delete(U,X::Y,Z), perm(Z,V)"; 172 | "delete(X,X::Y,Y)"; 173 | "delete(X,Y::Z,Y::W) :- delete(X,Z,W)"; 174 | "0 <= X"; 175 | "S(X) <= S(Y) :- X <= Y"];; 176 | 177 | prolog sortrules 178 | "sort(S(S(S(S(0))))::S(0)::0::S(S(0))::S(0)::nil,X)";; 179 | 180 | (* ------------------------------------------------------------------------- *) 181 | (* Yet with a simple swap of the first two predicates... *) 182 | (* ------------------------------------------------------------------------- *) 183 | 184 | let badrules = 185 | ["sort(X,Y) :- sorted(Y), perm(X,Y)"; 186 | "sorted(nil)"; 187 | "sorted(X::nil)"; 188 | "sorted(X::Y::Z) :- X <= Y, sorted(Y::Z)"; 189 | "perm(nil,nil)"; 190 | "perm(X::Y,U::V) :- delete(U,X::Y,Z), perm(Z,V)"; 191 | "delete(X,X::Y,Y)"; 192 | "delete(X,Y::Z,Y::W) :- delete(X,Z,W)"; 193 | "0 <= X"; 194 | "S(X) <= S(Y) :- X <= Y"];; 195 | 196 | (*** This no longer works 197 | 198 | prolog badrules 199 | "sort(S(S(S(S(0))))::S(0)::0::S(S(0))::S(0)::nil,X)";; 200 | 201 | ***) 202 | END_INTERACTIVE;; 203 | -} 204 | 205 | testProlog :: Test 206 | testProlog = TestLabel "Prolog" (TestList []) 207 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/PropExamples.hs: -------------------------------------------------------------------------------- 1 | -- | Some propositional formulas to test, and functions to generate classes. 2 | -- 3 | -- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) 4 | 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeSynonymInstances #-} 12 | 13 | module Data.Logic.ATP.PropExamples 14 | ( Knows(K) 15 | , mk_knows, mk_knows2 16 | , prime 17 | , ramsey 18 | , testPropExamples 19 | ) where 20 | 21 | import Data.Bits (Bits, shiftR) 22 | import Data.List as List (map) 23 | import Data.Logic.ATP.Formulas 24 | import Data.Logic.ATP.Lib (allsets, timeMessage) 25 | import Data.Logic.ATP.Lit ((.~.)) 26 | import Data.Logic.ATP.Pretty (HasFixity(precedence), Pretty(pPrint), prettyShow, text) 27 | import Data.Logic.ATP.Prop 28 | import Data.Set as Set 29 | import Prelude hiding (sum) 30 | import Test.HUnit 31 | 32 | -- | Generate assertion equivalent to R(s,t) <= n for the Ramsey number R(s,t) 33 | ramsey :: (IsPropositional pf, AtomOf pf ~ Knows Integer, Ord pf) => 34 | Integer -> Integer -> Integer -> pf 35 | ramsey s t n = 36 | let vertices = Set.fromList [1 .. n] in 37 | let yesgrps = Set.map (allsets (2 :: Integer)) (allsets s vertices) 38 | nogrps = Set.map (allsets (2 :: Integer)) (allsets t vertices) in 39 | let e xs = let [a, b] = Set.toAscList xs in atomic (K "p" a (Just b)) in 40 | list_disj (Set.map (list_conj . Set.map e) yesgrps) .|. list_disj (Set.map (list_conj . Set.map (\ p -> (.~.)(e p))) nogrps) 41 | 42 | data Knows a = K String a (Maybe a) deriving (Eq, Ord, Show) 43 | 44 | instance (Num a, Show a) => Pretty (Knows a) where 45 | pPrint (K s n mm) = text (s ++ show n ++ maybe "" (\ m -> "." ++ show m) mm) 46 | 47 | instance Num a => HasFixity (Knows a) where 48 | precedence _ = 9 49 | 50 | instance IsAtom (Knows Integer) 51 | 52 | -- Some currently tractable examples. (p. 36) 53 | test01 :: Test 54 | test01 = TestList [TestCase (assertEqual "ramsey 3 3 4" 55 | "(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)" 56 | -- "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" 57 | (prettyShow (ramsey 3 3 4 :: PFormula (Knows Integer)))), 58 | 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)))), 59 | 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))))] 60 | 61 | -- | Half adder. (p. 66) 62 | halfsum :: forall formula. IsPropositional formula => formula -> formula -> formula 63 | halfsum x y = x .<=>. ((.~.) y) 64 | 65 | halfcarry :: forall formula. IsPropositional formula => formula -> formula -> formula 66 | halfcarry x y = x .&. y 67 | 68 | ha :: forall formula. IsPropositional formula => formula -> formula -> formula -> formula -> formula 69 | ha x y s c = (s .<=>. halfsum x y) .&. (c .<=>. halfcarry x y) 70 | 71 | -- | Full adder. 72 | carry :: forall formula. IsPropositional formula => formula -> formula -> formula -> formula 73 | carry x y z = (x .&. y) .|. ((x .|. y) .&. z) 74 | 75 | sum :: forall formula. IsPropositional formula => formula -> formula -> formula -> formula 76 | sum x y z = halfsum (halfsum x y) z 77 | 78 | fa :: forall formula. IsPropositional formula => formula -> formula -> formula -> formula -> formula -> formula 79 | fa x y z s c = (s .<=>. sum x y z) .&. (c .<=>. carry x y z) 80 | 81 | -- | Useful idiom. 82 | conjoin :: (IsPropositional formula, Ord formula, Ord a) => (a -> formula) -> Set a -> formula 83 | conjoin f l = list_conj (Set.map f l) 84 | 85 | -- | n-bit ripple carry adder with carry c(0) propagated in and c(n) out. (p. 67) 86 | ripplecarry :: (IsPropositional formula, Ord formula, Ord a, Num a, Enum a) => 87 | (a -> formula) 88 | -> (a -> formula) 89 | -> (a -> formula) 90 | -> (a -> formula) 91 | -> a -> formula 92 | ripplecarry x y c out n = 93 | conjoin (\ i -> fa (x i) (y i) (c i) (out i) (c(i + 1))) (Set.fromList [0 .. (n - 1)]) 94 | 95 | -- Example. 96 | mk_knows :: (IsPropositional formula, AtomOf formula ~ Knows a) => String -> a -> formula 97 | mk_knows x i = atomic (K x i Nothing) 98 | mk_knows2 :: (IsPropositional formula, AtomOf formula ~ Knows a) => String -> a -> a -> formula 99 | mk_knows2 x i j = atomic (K x i (Just j)) 100 | 101 | test02 :: Test 102 | test02 = 103 | let [x, y, out, c] = List.map mk_knows ["X", "Y", "OUT", "C"] :: [Integer -> PFormula (Knows Integer)] in 104 | TestCase (assertEqual "ripplecarry x y c out 2" 105 | (((out 0 .<=>. ((x 0 .<=>. ((.~.) (y 0))) .<=>. ((.~.) (c 0)))) .&. 106 | (c 1 .<=>. ((x 0 .&. y 0) .|. ((x 0 .|. y 0) .&. c 0)))) .&. 107 | ((out 1 .<=>. ((x 1 .<=>. ((.~.) (y 1))) .<=>. ((.~.) (c 1)))) .&. 108 | (c 2 .<=>. ((x 1 .&. y 1) .|. ((x 1 .|. y 1) .&. c 1))))) 109 | (ripplecarry x y c out 2 :: PFormula (Knows Integer))) 110 | 111 | -- | Special case with 0 instead of c(0). 112 | ripplecarry0 :: (IsPropositional formula, Ord formula, Ord a, Num a, Enum a) => 113 | (a -> formula) 114 | -> (a -> formula) 115 | -> (a -> formula) 116 | -> (a -> formula) 117 | -> a -> formula 118 | ripplecarry0 x y c out n = 119 | psimplify 120 | (ripplecarry x y (\ i -> if i == 0 then false else c i) out n) 121 | 122 | -- | Carry-select adder 123 | ripplecarry1 :: (IsPropositional formula, Ord formula, Ord a, Num a, Enum a) => 124 | (a -> formula) 125 | -> (a -> formula) 126 | -> (a -> formula) 127 | -> (a -> formula) 128 | -> a -> formula 129 | ripplecarry1 x y c out n = 130 | psimplify 131 | (ripplecarry x y (\ i -> if i == 0 then true else c i) out n) 132 | 133 | mux :: forall formula. IsPropositional formula => formula -> formula -> formula -> formula 134 | mux sel in0 in1 = (((.~.) sel) .&. in0) .|. (sel .&. in1) 135 | 136 | offset :: forall t a. Num a => a -> (a -> t) -> a -> t 137 | offset n x i = x (n + i) 138 | 139 | carryselect :: (IsPropositional formula, Ord formula, Ord a, Num a, Enum a) => 140 | (a -> formula) 141 | -> (a -> formula) 142 | -> (a -> formula) 143 | -> (a -> formula) 144 | -> (a -> formula) 145 | -> (a -> formula) 146 | -> (a -> formula) 147 | -> (a -> formula) 148 | -> a -> a -> formula 149 | carryselect x y c0 c1 s0 s1 c s n k = 150 | let k' = min n k in 151 | let fm = ((ripplecarry0 x y c0 s0 k') .&. (ripplecarry1 x y c1 s1 k')) .&. 152 | (((c k') .<=>. (mux (c 0) (c0 k') (c1 k'))) .&. 153 | (conjoin (\ i -> (s i) .<=>. (mux (c 0) (s0 i) (s1 i))) 154 | (Set.fromList [0 .. (k' - 1)]))) in 155 | if k' < k then fm else 156 | fm .&. (carryselect 157 | (offset k x) (offset k y) (offset k c0) (offset k c1) 158 | (offset k s0) (offset k s1) (offset k c) (offset k s) 159 | (n - k) k) 160 | 161 | -- | Equivalence problems for carry-select vs ripple carry adders. (p. 69) 162 | mk_adder_test :: (IsPropositional formula, Ord formula, AtomOf formula ~ Knows a, Ord a, Num a, Enum a, Show a) => 163 | a -> a -> formula 164 | mk_adder_test n k = 165 | let [x, y, c, s, c0, s0, c1, s1, c2, s2] = 166 | List.map mk_knows ["x", "y", "c", "s", "c0", "s0", "c1", "s1", "c2", "s2"] in 167 | (((carryselect x y c0 c1 s0 s1 c s n k) .&. 168 | ((.~.) (c 0))) .&. 169 | (ripplecarry0 x y c2 s2 n)) .=>. 170 | (((c n) .<=>. (c2 n)) .&. 171 | (conjoin (\ i -> (s i) .<=>. (s2 i)) (Set.fromList [0 .. (n - 1)]))) 172 | 173 | -- | Ripple carry stage that separates off the final result. (p. 70) 174 | -- 175 | -- UUUUUUUUUUUUUUUUUUUU (u) 176 | -- + VVVVVVVVVVVVVVVVVVVV (v) 177 | -- 178 | -- = WWWWWWWWWWWWWWWWWWWW (w) 179 | -- + Z (z) 180 | 181 | rippleshift :: (IsPropositional formula, Ord formula, Ord a, Num a, Enum a) => 182 | (a -> formula) 183 | -> (a -> formula) 184 | -> (a -> formula) 185 | -> formula 186 | -> (a -> formula) 187 | -> a -> formula 188 | rippleshift u v c z w n = 189 | ripplecarry0 u v (\ i -> if i == n then w(n - 1) else c(i + 1)) 190 | (\ i -> if i == 0 then z else w(i - 1)) n 191 | 192 | -- | Naive multiplier based on repeated ripple carry. 193 | multiplier :: (IsPropositional formula, Ord formula, Ord a, Num a, Enum a) => 194 | (a -> a -> formula) 195 | -> (a -> a -> formula) 196 | -> (a -> a -> formula) 197 | -> (a -> formula) 198 | -> a 199 | -> formula 200 | multiplier x u v out n = 201 | if n == 1 then ((out 0) .<=>. (x 0 0)) .&. ((.~.)(out 1)) else 202 | psimplify (((out 0) .<=>. (x 0 0)) .&. 203 | ((rippleshift 204 | (\ i -> if i == n - 1 then false else x 0 (i + 1)) 205 | (x 1) (v 2) (out 1) (u 2) n) .&. 206 | (if n == 2 then ((out 2) .<=>. (u 2 0)) .&. ((out 3) .<=>. (u 2 1)) else 207 | conjoin (\ k -> rippleshift (u k) (x k) (v(k + 1)) (out k) 208 | (if k == n - 1 then \ i -> out(n + i) 209 | else u(k + 1)) n) (Set.fromList [2 .. (n - 1)])))) 210 | 211 | -- | Primality examples. (p. 71) 212 | -- 213 | -- For large examples, should use 'Integer' instead of 'Int' in these functions. 214 | bitlength :: forall b a. (Num a, Num b, Bits b) => b -> a 215 | bitlength x = if x == 0 then 0 else 1 + bitlength (shiftR x 1);; 216 | 217 | bit :: forall a b. (Num a, Eq a, Bits b, Integral b) => a -> b -> Bool 218 | bit n x = if n == 0 then x `mod` 2 == 1 else bit (n - 1) (shiftR x 1) 219 | 220 | congruent_to :: (IsPropositional formula, Ord formula, Bits b, Ord a, Num a, Integral b, Enum a) => 221 | (a -> formula) -> b -> a -> formula 222 | congruent_to x m n = 223 | conjoin (\ i -> if bit i m then x i else (.~.)(x i)) 224 | (Set.fromList [0 .. (n - 1)]) 225 | 226 | prime :: (IsPropositional formula, Ord formula, AtomOf formula ~ Knows Integer) => Integer -> formula 227 | prime p = 228 | let [x, y, out] = List.map mk_knows ["x", "y", "out"] in 229 | let m i j = (x i) .&. (y j) 230 | [u, v] = List.map mk_knows2 ["u", "v"] in 231 | let (n :: Integer) = bitlength p in 232 | (.~.) (multiplier m u v out (n - 1) .&. congruent_to out p (max n (2 * n - 2))) 233 | 234 | -- Examples. (p. 72) 235 | 236 | type F = PFormula (Knows Integer) 237 | 238 | test03 :: Test 239 | test03 = 240 | TestList [TestCase (timeMessage (\_ t -> "\nTime to prove (prime 7): " ++ show t) (assertEqual "tautology(prime 7)" True (tautology (prime 7 :: F)))), 241 | TestCase (timeMessage (\_ t -> "\nTime to prove (prime 9): " ++ show t) (assertEqual "tautology(prime 9)" False (tautology (prime 9 :: F)))), 242 | TestCase (timeMessage (\_ t -> "\nTime to prove (prime 11): " ++ show t) (assertEqual "tautology(prime 11)" True (tautology (prime 11 :: F))))] 243 | 244 | testPropExamples :: Test 245 | testPropExamples = TestLabel "PropExamples" (TestList [test01, test02, test03]) 246 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/Quantified.hs: -------------------------------------------------------------------------------- 1 | -- | 'IsQuantified' is a subclass of 'IsPropositional' of formula 2 | -- types that support existential and universal quantification. 3 | 4 | {-# LANGUAGE DeriveDataTypeable #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE FunctionalDependencies #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | module Data.Logic.ATP.Quantified 17 | ( Quant((:!:), (:?:)) 18 | , IsQuantified(VarOf, quant, foldQuantified) 19 | , for_all, (∀) 20 | , exists, (∃) 21 | , precedenceQuantified 22 | , associativityQuantified 23 | , prettyQuantified 24 | , showQuantified 25 | , zipQuantified 26 | , convertQuantified 27 | , onatomsQuantified 28 | , overatomsQuantified 29 | -- * Concrete instance of a quantified formula type 30 | , QFormula(F, T, Atom, Not, And, Or, Imp, Iff, Forall, Exists) 31 | ) where 32 | 33 | import Data.Data (Data) 34 | import Data.Logic.ATP.Apply (HasApply(TermOf)) 35 | import Data.Logic.ATP.Formulas (fromBool, IsAtom, IsFormula(..), onatoms, prettyBool) 36 | import Data.Logic.ATP.Lit ((.~.), IsLiteral(foldLiteral'), IsLiteral(..)) 37 | import Data.Logic.ATP.Pretty as Pretty 38 | ((<>), Associativity(InfixN, InfixR, InfixA), Doc, HasFixity(precedence, associativity), 39 | Precedence, Side(Top, LHS, RHS, Unary), testParen, text, 40 | andPrec, orPrec, impPrec, iffPrec, notPrec, leafPrec, quantPrec) 41 | import Data.Logic.ATP.Prop (BinOp(..), binop, IsPropositional((.&.), (.|.), (.=>.), (.<=>.), foldPropositional', foldCombination)) 42 | import Data.Logic.ATP.Term (IsTerm(TVarOf), IsVariable) 43 | import Data.Typeable (Typeable) 44 | import Prelude hiding (pred) 45 | import Text.PrettyPrint (fsep) 46 | import Text.PrettyPrint.HughesPJClass (maybeParens, Pretty(pPrint, pPrintPrec), PrettyLevel, prettyNormal) 47 | 48 | ------------------------- 49 | -- QUANTIFIED FORMULAS -- 50 | ------------------------- 51 | 52 | -- | The two types of quantification 53 | data Quant 54 | = (:!:) -- ^ for_all 55 | | (:?:) -- ^ exists 56 | deriving (Eq, Ord, Data, Typeable, Show) 57 | 58 | -- | Class of quantified formulas. 59 | class (IsPropositional formula, IsVariable (VarOf formula)) => IsQuantified formula where 60 | type (VarOf formula) -- A type function mapping formula to the associated variable 61 | quant :: Quant -> VarOf formula -> formula -> formula 62 | foldQuantified :: (Quant -> VarOf formula -> formula -> r) 63 | -> (formula -> BinOp -> formula-> r) 64 | -> (formula -> r) 65 | -> (Bool -> r) 66 | -> (AtomOf formula -> r) 67 | -> formula -> r 68 | 69 | for_all :: IsQuantified formula => VarOf formula -> formula -> formula 70 | for_all = quant (:!:) 71 | exists :: IsQuantified formula => VarOf formula -> formula -> formula 72 | exists = quant (:?:) 73 | 74 | -- | ∀ can't be a function when -XUnicodeSyntax is enabled. 75 | (∀) :: IsQuantified formula => VarOf formula -> formula -> formula 76 | infixr 1 ∀ 77 | (∀) = for_all 78 | (∃) :: IsQuantified formula => VarOf formula -> formula -> formula 79 | infixr 1 ∃ 80 | (∃) = exists 81 | 82 | precedenceQuantified :: forall formula. IsQuantified formula => formula -> Precedence 83 | precedenceQuantified = foldQuantified qu co ne tf at 84 | where 85 | qu _ _ _ = quantPrec 86 | co _ (:&:) _ = andPrec 87 | co _ (:|:) _ = orPrec 88 | co _ (:=>:) _ = impPrec 89 | co _ (:<=>:) _ = iffPrec 90 | ne _ = notPrec 91 | tf _ = leafPrec 92 | at = (precedence :: Num a => AtomOf formula -> a) 93 | 94 | associativityQuantified :: forall formula. IsQuantified formula => formula -> Associativity 95 | associativityQuantified = foldQuantified qu co ne tf at 96 | where 97 | qu _ _ _ = Pretty.InfixR 98 | ne _ = Pretty.InfixA 99 | co _ (:&:) _ = Pretty.InfixA 100 | co _ (:|:) _ = Pretty.InfixA 101 | co _ (:=>:) _ = Pretty.InfixR 102 | co _ (:<=>:) _ = Pretty.InfixA 103 | tf _ = Pretty.InfixN 104 | at = associativity 105 | 106 | -- | Implementation of 'Pretty' for 'IsQuantified' types. 107 | prettyQuantified :: forall fof v. (IsQuantified fof, v ~ VarOf fof) => 108 | Side -> PrettyLevel -> Rational -> fof -> Doc 109 | prettyQuantified side l r fm = 110 | maybeParens (l > prettyNormal || testParen side r (precedence fm) (associativity fm)) $ foldQuantified (\op v p -> qu op [v] p) co ne tf at fm 111 | -- maybeParens (r > precedence fm) $ foldQuantified (\op v p -> qu op [v] p) co ne tf at fm 112 | where 113 | -- Collect similarly quantified variables 114 | qu :: Quant -> [v] -> fof -> Doc 115 | qu op vs p' = foldQuantified (qu' op vs p') (\_ _ _ -> qu'' op vs p') (\_ -> qu'' op vs p') 116 | (\_ -> qu'' op vs p') (\_ -> qu'' op vs p') p' 117 | qu' :: Quant -> [v] -> fof -> Quant -> v -> fof -> Doc 118 | qu' op vs _ op' v p' | op == op' = qu op (v : vs) p' 119 | qu' op vs p _ _ _ = qu'' op vs p 120 | qu'' :: Quant -> [v] -> fof -> Doc 121 | qu'' _op [] p = prettyQuantified Unary l r p 122 | qu'' op vs p = text (case op of (:!:) -> "∀"; (:?:) -> "∃") <> 123 | fsep (map pPrint (reverse vs)) <> 124 | text ". " <> prettyQuantified Unary l (precedence fm + 1) p 125 | co :: fof -> BinOp -> fof -> Doc 126 | co p (:&:) q = prettyQuantified LHS l (precedence fm) p <> text "∧" <> prettyQuantified RHS l (precedence fm) q 127 | co p (:|:) q = prettyQuantified LHS l (precedence fm) p <> text "∨" <> prettyQuantified RHS l (precedence fm) q 128 | co p (:=>:) q = prettyQuantified LHS l (precedence fm) p <> text "⇒" <> prettyQuantified RHS l (precedence fm) q 129 | co p (:<=>:) q = prettyQuantified LHS l (precedence fm) p <> text "⇔" <> prettyQuantified RHS l (precedence fm) q 130 | ne p = text "¬" <> prettyQuantified Unary l (precedence fm) p 131 | tf x = prettyBool x 132 | at x = pPrintPrec l r x -- maybeParens (d > PrettyLevel atomPrec) $ pPrint x 133 | 134 | -- | Implementation of 'showsPrec' for 'IsQuantified' types. 135 | showQuantified :: IsQuantified formula => Side -> Int -> formula -> ShowS 136 | showQuantified side r fm = 137 | showParen (testParen side r (precedence fm) (associativity fm)) $ foldQuantified qu co ne tf at fm 138 | where 139 | qu (:!:) x p = showString "for_all " . showString (show x) . showString " " . showQuantified Unary (precedence fm + 1) p 140 | qu (:?:) x p = showString "exists " . showString (show x) . showString " " . showQuantified Unary (precedence fm + 1) p 141 | co p (:&:) q = showQuantified LHS (precedence fm) p . showString " .&. " . showQuantified RHS (precedence fm) q 142 | co p (:|:) q = showQuantified LHS (precedence fm) p . showString " .|. " . showQuantified RHS (precedence fm) q 143 | co p (:=>:) q = showQuantified LHS (precedence fm) p . showString " .=>. " . showQuantified RHS (precedence fm) q 144 | co p (:<=>:) q = showQuantified LHS (precedence fm) p . showString " .<=>. " . showQuantified RHS (precedence fm) q 145 | ne p = showString "(.~.) " . showQuantified Unary (succ (precedence fm)) p 146 | tf x = showsPrec (precedence fm) x 147 | at x = showsPrec (precedence fm) x 148 | 149 | -- | Combine two formulas if they are similar. 150 | zipQuantified :: IsQuantified formula => 151 | (Quant -> VarOf formula -> formula -> Quant -> VarOf formula -> formula -> Maybe r) 152 | -> (formula -> BinOp -> formula -> formula -> BinOp -> formula -> Maybe r) 153 | -> (formula -> formula -> Maybe r) 154 | -> (Bool -> Bool -> Maybe r) 155 | -> ((AtomOf formula) -> (AtomOf formula) -> Maybe r) 156 | -> formula -> formula -> Maybe r 157 | zipQuantified qu co ne tf at fm1 fm2 = 158 | foldQuantified qu' co' ne' tf' at' fm1 159 | where 160 | qu' op1 v1 p1 = foldQuantified (qu op1 v1 p1) (\ _ _ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) fm2 161 | co' l1 op1 r1 = foldQuantified (\ _ _ _ -> Nothing) (co l1 op1 r1) (\ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) fm2 162 | ne' x1 = foldQuantified (\ _ _ _ -> Nothing) (\ _ _ _ -> Nothing) (ne x1) (\ _ -> Nothing) (\ _ -> Nothing) fm2 163 | tf' x1 = foldQuantified (\ _ _ _ -> Nothing) (\ _ _ _ -> Nothing) (\ _ -> Nothing) (tf x1) (\ _ -> Nothing) fm2 164 | at' atom1 = foldQuantified (\ _ _ _ -> Nothing) (\ _ _ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) (at atom1) fm2 165 | 166 | -- | Convert any instance of IsQuantified to any other by 167 | -- specifying the result type. 168 | convertQuantified :: forall f1 f2. 169 | (IsQuantified f1, IsQuantified f2) => 170 | (AtomOf f1 -> AtomOf f2) -> (VarOf f1 -> VarOf f2) -> f1 -> f2 171 | convertQuantified ca cv f1 = 172 | foldQuantified qu co ne tf at f1 173 | where 174 | qu :: Quant -> VarOf f1 -> f1 -> f2 175 | qu (:!:) x p = for_all (cv x :: VarOf f2) (convertQuantified ca cv p :: f2) 176 | qu (:?:) x p = exists (cv x :: VarOf f2) (convertQuantified ca cv p :: f2) 177 | co p (:&:) q = convertQuantified ca cv p .&. convertQuantified ca cv q 178 | co p (:|:) q = convertQuantified ca cv p .|. convertQuantified ca cv q 179 | co p (:=>:) q = convertQuantified ca cv p .=>. convertQuantified ca cv q 180 | co p (:<=>:) q = convertQuantified ca cv p .<=>. convertQuantified ca cv q 181 | ne p = (.~.) (convertQuantified ca cv p) 182 | tf :: Bool -> f2 183 | tf = fromBool 184 | at :: AtomOf f1 -> f2 185 | at = atomic . ca 186 | 187 | onatomsQuantified :: IsQuantified formula => (AtomOf formula -> AtomOf formula) -> formula -> formula 188 | onatomsQuantified f fm = 189 | foldQuantified qu co ne tf at fm 190 | where 191 | qu op v p = quant op v (onatomsQuantified f p) 192 | ne p = (.~.) (onatomsQuantified f p) 193 | co p op q = binop (onatomsQuantified f p) op (onatomsQuantified f q) 194 | tf flag = fromBool flag 195 | at x = atomic (f x) 196 | 197 | overatomsQuantified :: IsQuantified fof => (AtomOf fof -> r -> r) -> fof -> r -> r 198 | overatomsQuantified f fof r0 = 199 | foldQuantified qu co ne (const r0) (flip f r0) fof 200 | where 201 | qu _ _ fof' = overatomsQuantified f fof' r0 202 | ne fof' = overatomsQuantified f fof' r0 203 | co p _ q = overatomsQuantified f p (overatomsQuantified f q r0) 204 | 205 | data QFormula v atom 206 | = F 207 | | T 208 | | Atom atom 209 | | Not (QFormula v atom) 210 | | And (QFormula v atom) (QFormula v atom) 211 | | Or (QFormula v atom) (QFormula v atom) 212 | | Imp (QFormula v atom) (QFormula v atom) 213 | | Iff (QFormula v atom) (QFormula v atom) 214 | | Forall v (QFormula v atom) 215 | | Exists v (QFormula v atom) 216 | deriving (Eq, Ord, Data, Typeable, Read) 217 | 218 | instance (HasApply atom, IsTerm term, term ~ TermOf atom, v ~ TVarOf term) => Pretty (QFormula v atom) where 219 | pPrintPrec = prettyQuantified Top 220 | 221 | -- The IsFormula instance for QFormula 222 | instance (HasApply atom, v ~ TVarOf (TermOf atom)) => IsFormula (QFormula v atom) where 223 | type AtomOf (QFormula v atom) = atom 224 | asBool T = Just True 225 | asBool F = Just False 226 | asBool _ = Nothing 227 | true = T 228 | false = F 229 | atomic = Atom 230 | overatoms = overatomsQuantified 231 | onatoms = onatomsQuantified 232 | 233 | instance (IsFormula (QFormula v atom), HasApply atom, v ~ TVarOf (TermOf atom)) => IsPropositional (QFormula v atom) where 234 | (.|.) = Or 235 | (.&.) = And 236 | (.=>.) = Imp 237 | (.<=>.) = Iff 238 | foldPropositional' ho co ne tf at fm = 239 | case fm of 240 | And p q -> co p (:&:) q 241 | Or p q -> co p (:|:) q 242 | Imp p q -> co p (:=>:) q 243 | Iff p q -> co p (:<=>:) q 244 | _ -> foldLiteral' ho ne tf at fm 245 | foldCombination other dj cj imp iff fm = 246 | case fm of 247 | Or a b -> a `dj` b 248 | And a b -> a `cj` b 249 | Imp a b -> a `imp` b 250 | Iff a b -> a `iff` b 251 | _ -> other fm 252 | 253 | instance (IsPropositional (QFormula v atom), IsVariable v, IsAtom atom) => IsQuantified (QFormula v atom) where 254 | type VarOf (QFormula v atom) = v 255 | quant (:!:) = Forall 256 | quant (:?:) = Exists 257 | foldQuantified qu _co _ne _tf _at (Forall v fm) = qu (:!:) v fm 258 | foldQuantified qu _co _ne _tf _at (Exists v fm) = qu (:?:) v fm 259 | foldQuantified _qu co ne tf at fm = 260 | foldPropositional' (\_ -> error "IsQuantified QFormula") co ne tf at fm 261 | 262 | -- Build a Haskell expression for this formula 263 | instance IsQuantified (QFormula v atom) => Show (QFormula v atom) where 264 | showsPrec = showQuantified Top 265 | 266 | -- Precedence information for QFormula 267 | instance IsQuantified (QFormula v atom) => HasFixity (QFormula v atom) where 268 | precedence = precedenceQuantified 269 | associativity = associativityQuantified 270 | 271 | instance (HasApply atom, v ~ TVarOf (TermOf atom)) => IsLiteral (QFormula v atom) where 272 | naiveNegate = Not 273 | foldNegation normal inverted (Not x) = foldNegation inverted normal x 274 | foldNegation normal _ x = normal x 275 | foldLiteral' ho ne tf at fm = 276 | case fm of 277 | T -> tf True 278 | F -> tf False 279 | Atom a -> at a 280 | Not p -> ne p 281 | _ -> ho fm 282 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/Skolem.hs: -------------------------------------------------------------------------------- 1 | -- | Prenex and Skolem normal forms. 2 | -- 3 | -- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) 4 | 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FunctionalDependencies #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE QuasiQuotes #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | 16 | module Data.Logic.ATP.Skolem 17 | ( 18 | -- * Class of Skolem functions 19 | HasSkolem(SVarOf, toSkolem, foldSkolem, variantSkolem) 20 | , showSkolem 21 | , prettySkolem 22 | -- * Skolem monad 23 | , SkolemM 24 | , runSkolem 25 | , SkolemT 26 | , runSkolemT 27 | -- * Skolemization procedure 28 | , simplify 29 | , nnf 30 | , pnf 31 | , skolems 32 | , askolemize 33 | , skolemize 34 | , specialize 35 | -- * Normalization 36 | , simpdnf' 37 | , simpcnf' 38 | -- * Instances 39 | , Function(Fn, Skolem) 40 | , Formula, SkTerm, SkAtom 41 | -- * Tests 42 | , testSkolem 43 | ) where 44 | 45 | import Control.Monad.Identity (Identity, runIdentity) 46 | import Control.Monad.State (runStateT, StateT, get, modify) 47 | import Data.Data (Data) 48 | import Data.List as List (map) 49 | import Data.Logic.ATP.Apply (functions, HasApply(TermOf, PredOf), pApp, Predicate) 50 | import Data.Logic.ATP.Equate (FOL) 51 | import Data.Logic.ATP.FOL (fv, IsFirstOrder, subst) 52 | import Data.Logic.ATP.Formulas (IsFormula(AtomOf), false, true, atomic) 53 | import Data.Logic.ATP.Lib (setAny, distrib) 54 | import Data.Logic.ATP.Lit ((.~.), negate) 55 | import Data.Logic.ATP.Pretty (brackets, Doc, Pretty(pPrint), prettyShow, text) 56 | import Data.Logic.ATP.Prop ((.&.), (.|.), (.=>.), (.<=>.), BinOp((:&:), (:|:), (:=>:), (:<=>:)), 57 | convertToPropositional, foldPropositional', JustPropositional, PFormula, psimplify1, trivial) 58 | import Data.Logic.ATP.Quantified (exists, for_all, IsQuantified(VarOf, foldQuantified), 59 | QFormula, quant, Quant((:?:), (:!:))) 60 | import Data.Logic.ATP.Term (fApp, IsFunction, IsTerm(TVarOf, FunOf), IsVariable, Term, V, variant, vt) 61 | import Data.Map.Strict as Map (singleton) 62 | import Data.Monoid ((<>)) 63 | import Data.Set as Set (empty, filter, insert, isProperSubsetOf, map, member, notMember, Set, singleton, toAscList, union) 64 | import Data.String (IsString(fromString)) 65 | import Data.Typeable (Typeable) 66 | import Prelude hiding (negate) 67 | import Test.HUnit 68 | 69 | -- | Class of functions that include embedded Skolem functions 70 | -- 71 | -- A Skolem function is created to eliminate an an existentially 72 | -- quantified variable. The idea is that if we have a predicate 73 | -- @P[x,y,z]@, and @z@ is existentially quantified, then @P@ is only 74 | -- satisfiable if there *exists* at least one @z@ that causes @P@ to 75 | -- be true. Therefore, we envision a function @sKz[x,y]@ whose value 76 | -- is one of the z's that cause @P@ to be satisfied (if there are any; 77 | -- if the formula is satisfiable there must be.) Because we are 78 | -- trying to determine if there is a satisfying triple @x, y, z@, the 79 | -- Skolem function @sKz@ will have to be a function of @x@ and @y@, so 80 | -- we make these parameters. Now, if @P[x,y,z]@ is satisfiable, there 81 | -- will be a function sKz which can be substituted in such that 82 | -- @P[x,y,sKz[x,y]]@ is also satisfiable. Thus, using this mechanism 83 | -- we can eliminate all the formula's existential quantifiers and some 84 | -- of its variables. 85 | class (IsFunction function, IsVariable (SVarOf function)) => HasSkolem function where 86 | type SVarOf function 87 | toSkolem :: SVarOf function -> Int -> function 88 | -- ^ Create a skolem function with a variant number that differs 89 | -- from all the members of the set. 90 | foldSkolem :: (function -> r) -> (SVarOf function -> Int -> r) -> function -> r 91 | variantSkolem :: function -> Set function -> function 92 | -- ^ Return a function based on f but different from any set 93 | -- element. The result may be f itself if f is not a member of 94 | -- the set. 95 | 96 | -- fromSkolem :: HasSkolem function v => function -> Maybe v 97 | -- fromSkolem = foldSkolem (const Nothing) Just 98 | 99 | showSkolem :: (HasSkolem function, IsVariable (SVarOf function)) => function -> String 100 | showSkolem = foldSkolem (show . prettyShow) (\v n -> "(toSkolem " ++ show v ++ " " ++ show n ++ ")") 101 | 102 | prettySkolem :: HasSkolem function => (function -> Doc) -> function -> Doc 103 | prettySkolem prettyFunction = 104 | foldSkolem prettyFunction (\v n -> text "sK" <> brackets (pPrint v <> if n == 1 then mempty else (text "." <> pPrint (show n)))) 105 | 106 | -- | State monad for generating Skolem functions and constants. 107 | type SkolemT m function = StateT (SkolemState function) m 108 | type SkolemM function = StateT (SkolemState function) Identity 109 | 110 | -- | The state associated with the Skolem monad. 111 | data SkolemState function 112 | = SkolemState 113 | { skolemSet :: Set function 114 | -- ^ The set of allocated skolem functions 115 | , univQuant :: [String] 116 | -- ^ The variables which are universally quantified in the 117 | -- current scope, in the order they were encountered. During 118 | -- Skolemization these are the parameters passed to the Skolem 119 | -- function. 120 | } 121 | 122 | -- | Run a computation in a stacked invocation of the Skolem monad. 123 | runSkolemT :: (Monad m, IsFunction function) => SkolemT m function a -> m a 124 | runSkolemT action = (runStateT action) newSkolemState >>= return . fst 125 | where 126 | newSkolemState :: IsFunction function => SkolemState function 127 | newSkolemState 128 | = SkolemState 129 | { skolemSet = mempty 130 | , univQuant = [] 131 | } 132 | 133 | -- | Run a pure computation in the Skolem monad. 134 | runSkolem :: IsFunction function => SkolemT Identity function a -> a 135 | runSkolem = runIdentity . runSkolemT 136 | 137 | -- ------------------------------------------------------------------------- 138 | -- Simplification, normal forms, and the skolemization procedure 139 | -- ------------------------------------------------------------------------- 140 | 141 | -- | Routine simplification. Like "psimplify" but with quantifier clauses. 142 | simplify :: IsFirstOrder formula => formula -> formula 143 | simplify fm = 144 | foldQuantified qu co ne (\_ -> fm) (\_ -> fm) fm 145 | where 146 | qu (:!:) x p = simplify1 (for_all x (simplify p)) 147 | qu (:?:) x p = simplify1 (exists x (simplify p)) 148 | ne p = simplify1 ((.~.) (simplify p)) 149 | co p (:&:) q = simplify1 (simplify p .&. simplify q) 150 | co p (:|:) q = simplify1 (simplify p .|. simplify q) 151 | co p (:=>:) q = simplify1 (simplify p .=>. simplify q) 152 | co p (:<=>:) q = simplify1 (simplify p .<=>. simplify q) 153 | 154 | simplify1 :: IsFirstOrder formula => formula -> formula 155 | simplify1 fm = 156 | foldQuantified qu (\_ _ _ -> psimplify1 fm) (\_ -> psimplify1 fm) (\_ -> psimplify1 fm) (\_ -> psimplify1 fm) fm 157 | where 158 | qu _ x p = if member x (fv p) then fm else p 159 | 160 | -- Example. 161 | test01 :: Test 162 | test01 = TestCase $ assertEqual ("simplify (p. 140) " ++ prettyShow fm) expected input 163 | where input = prettyShow (simplify fm) 164 | expected = prettyShow ((for_all "x" (pApp "P" [vt "x"])) .=>. (pApp "Q" []) :: Formula) 165 | fm :: Formula 166 | fm = (for_all "x" (for_all "y" (pApp "P" [vt "x"] .|. (pApp "P" [vt "y"] .&. false)))) .=>. exists "z" (pApp "Q" []) 167 | 168 | -- | Negation normal form for first order formulas 169 | nnf :: IsFirstOrder formula => formula -> formula 170 | nnf = nnf1 . simplify 171 | 172 | nnf1 :: IsQuantified formula => formula -> formula 173 | nnf1 fm = 174 | foldQuantified qu co ne (\_ -> fm) (\_ -> fm) fm 175 | where 176 | qu (:!:) x p = quant (:!:) x (nnf1 p) 177 | qu (:?:) x p = quant (:?:) x (nnf1 p) 178 | ne p = foldQuantified quNot coNot neNot (\_ -> fm) (\_ -> fm) p 179 | co p (:&:) q = nnf1 p .&. nnf1 q 180 | co p (:|:) q = nnf1 p .|. nnf1 q 181 | co p (:=>:) q = nnf1 ((.~.) p) .|. nnf1 q 182 | co p (:<=>:) q = (nnf1 p .&. nnf1 q) .|. (nnf1 ((.~.) p) .&. nnf1 ((.~.) q)) 183 | quNot (:!:) x p = quant (:?:) x (nnf1 ((.~.) p)) 184 | quNot (:?:) x p = quant (:!:) x (nnf1 ((.~.) p)) 185 | neNot p = nnf1 p 186 | coNot p (:&:) q = nnf1 ((.~.) p) .|. nnf1 ((.~.) q) 187 | coNot p (:|:) q = nnf1 ((.~.) p) .&. nnf1 ((.~.) q) 188 | coNot p (:=>:) q = nnf1 p .&. nnf1 ((.~.) q) 189 | coNot p (:<=>:) q = (nnf1 p .&. nnf1 ((.~.) q)) .|. (nnf1 ((.~.) p) .&. nnf1 q) 190 | 191 | -- Example of NNF function in action. 192 | test02 :: Test 193 | test02 = TestCase $ assertEqual "nnf (p. 140)" expected input 194 | where p = "P" 195 | q = "Q" 196 | input = nnf fm 197 | expected = exists "x" ((.~.)(pApp p [vt "x"])) .|. 198 | ((exists "y" (pApp q [vt "y"]) .&. exists "z" ((pApp p [vt "z"]) .&. (pApp q [vt "z"]))) .|. 199 | (for_all "y" ((.~.)(pApp q [vt "y"])) .&. 200 | for_all "z" (((.~.)(pApp p [vt "z"])) .|. ((.~.)(pApp q [vt "z"])))) :: Formula) 201 | fm :: Formula 202 | fm = (for_all "x" (pApp p [vt "x"])) .=>. ((exists "y" (pApp q [vt "y"])) .<=>. exists "z" (pApp p [vt "z"] .&. pApp q [vt "z"])) 203 | 204 | -- | Prenex normal form. 205 | pnf :: IsFirstOrder formula => formula -> formula 206 | pnf = prenex . nnf . simplify 207 | 208 | prenex :: IsFirstOrder formula => formula -> formula 209 | prenex fm = 210 | foldQuantified qu co (\ _ -> fm) (\ _ -> fm) (\ _ -> fm) fm 211 | where 212 | qu op x p = quant op x (prenex p) 213 | co l (:&:) r = pullquants (prenex l .&. prenex r) 214 | co l (:|:) r = pullquants (prenex l .|. prenex r) 215 | co _ _ _ = fm 216 | 217 | pullquants :: IsFirstOrder formula => formula -> formula 218 | pullquants fm = 219 | foldQuantified (\_ _ _ -> fm) pullQuantsCombine (\_ -> fm) (\_ -> fm) (\_ -> fm) fm 220 | where 221 | pullQuantsCombine l op r = 222 | case (getQuant l, op, getQuant r) of 223 | (Just ((:!:), vl, l'), (:&:), Just ((:!:), vr, r')) -> pullq (True, True) fm for_all (.&.) vl vr l' r' 224 | (Just ((:?:), vl, l'), (:|:), Just ((:?:), vr, r')) -> pullq (True, True) fm exists (.|.) vl vr l' r' 225 | (Just ((:!:), vl, l'), (:&:), _) -> pullq (True, False) fm for_all (.&.) vl vl l' r 226 | (_, (:&:), Just ((:!:), vr, r')) -> pullq (False, True) fm for_all (.&.) vr vr l r' 227 | (Just ((:!:), vl, l'), (:|:), _) -> pullq (True, False) fm for_all (.|.) vl vl l' r 228 | (_, (:|:), Just ((:!:), vr, r')) -> pullq (False, True) fm for_all (.|.) vr vr l r' 229 | (Just ((:?:), vl, l'), (:&:), _) -> pullq (True, False) fm exists (.&.) vl vl l' r 230 | (_, (:&:), Just ((:?:), vr, r')) -> pullq (False, True) fm exists (.&.) vr vr l r' 231 | (Just ((:?:), vl, l'), (:|:), _) -> pullq (True, False) fm exists (.|.) vl vl l' r 232 | (_, (:|:), Just ((:?:), vr, r')) -> pullq (False, True) fm exists (.|.) vr vr l r' 233 | _ -> fm 234 | getQuant = foldQuantified (\ op v f -> Just (op, v, f)) (\ _ _ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) (\ _ -> Nothing) 235 | 236 | pullq :: (IsFirstOrder formula, v ~ VarOf formula) => 237 | (Bool, Bool) 238 | -> formula 239 | -> (v -> formula -> formula) 240 | -> (formula -> formula -> formula) 241 | -> v 242 | -> v 243 | -> formula 244 | -> formula 245 | -> formula 246 | pullq (l,r) fm qu op x y p q = 247 | let z = variant x (fv fm) in 248 | let p' = if l then subst (Map.singleton x (vt z)) p else p 249 | q' = if r then subst (Map.singleton y (vt z)) q else q in 250 | qu z (pullquants (op p' q')) 251 | 252 | -- Example. 253 | 254 | test03 :: Test 255 | test03 = TestCase $ assertEqual "pnf (p. 144)" (prettyShow expected) (prettyShow input) 256 | where p = "P" 257 | q = "Q" 258 | r = "R" 259 | input = pnf fm 260 | expected = exists "x" (for_all "z" 261 | ((((.~.)(pApp p [vt "x"])) .&. ((.~.)(pApp r [vt "y"]))) .|. 262 | ((pApp q [vt "x"]) .|. 263 | (((.~.)(pApp p [vt "z"])) .|. 264 | ((.~.)(pApp q [vt "z"])))))) :: Formula 265 | fm :: Formula 266 | fm = (for_all "x" (pApp p [vt "x"]) .|. (pApp r [vt "y"])) .=>. 267 | exists "y" (exists "z" ((pApp q [vt "y"]) .|. ((.~.)(exists "z" (pApp p [vt "z"] .&. pApp q [vt "z"]))))) 268 | 269 | -- | Extract the skolem functions from a formula. 270 | skolems :: (IsFormula formula, HasSkolem function, HasApply atom, Ord function, 271 | atom ~ AtomOf formula, 272 | term ~ TermOf atom, 273 | function ~ FunOf term {-, 274 | v ~ TVarOf term, 275 | v ~ SVarOf function-}) => formula -> Set function 276 | skolems = Set.filter (foldSkolem (const False) (\_ _ -> True)) . Set.map fst . functions 277 | 278 | -- | Core Skolemization function. 279 | -- 280 | -- Skolemize the formula by removing the existential quantifiers and 281 | -- replacing the variables they quantify with skolem functions (and 282 | -- constants, which are functions of zero variables.) The Skolem 283 | -- functions are new functions (obtained from the SkolemT monad) which 284 | -- are applied to the list of variables which are universally 285 | -- quantified in the context where the existential quantifier 286 | -- appeared. 287 | skolem :: (IsFirstOrder formula, HasSkolem function, Monad m, 288 | atom ~ AtomOf formula, 289 | term ~ TermOf atom, 290 | function ~ FunOf term, 291 | VarOf formula ~ SVarOf function {-, 292 | predicate ~ PredOf atom-}) => 293 | formula -> SkolemT m function formula 294 | skolem fm = 295 | foldQuantified qu co ne tf (return . atomic) fm 296 | where 297 | qu (:?:) y p = 298 | do sk <- newSkolem y 299 | let xs = fv fm 300 | let fx = fApp sk (List.map vt (Set.toAscList xs)) 301 | skolem (subst (Map.singleton y fx) p) 302 | qu (:!:) x p = skolem p >>= return . for_all x 303 | co l (:&:) r = skolem2 (.&.) l r 304 | co l (:|:) r = skolem2 (.|.) l r 305 | co _ _ _ = return fm 306 | ne _ = return fm 307 | tf True = return true 308 | tf False = return false 309 | 310 | newSkolem :: (Monad m, HasSkolem function, v ~ SVarOf function) => v -> SkolemT m function function 311 | newSkolem v = do 312 | f <- variantSkolem (toSkolem v 1) <$> skolemSet <$> get 313 | modify (\s -> s {skolemSet = Set.insert f (skolemSet s)}) 314 | return f 315 | 316 | skolem2 :: (IsFirstOrder formula, HasSkolem function, Monad m, 317 | atom ~ AtomOf formula, 318 | term ~ TermOf atom, 319 | function ~ FunOf term, 320 | VarOf formula ~ SVarOf function) => 321 | (formula -> formula -> formula) -> formula -> formula -> SkolemT m function formula 322 | skolem2 cons p q = 323 | skolem p >>= \ p' -> 324 | skolem q >>= \ q' -> 325 | return (cons p' q') 326 | 327 | -- | Overall Skolemization function. 328 | askolemize :: (IsFirstOrder formula, HasSkolem function, Monad m, 329 | atom ~ AtomOf formula, 330 | term ~ TermOf atom, 331 | function ~ FunOf term, 332 | VarOf formula ~ SVarOf function) => 333 | formula -> SkolemT m function formula 334 | askolemize = skolem . nnf . simplify 335 | 336 | -- | Remove the leading universal quantifiers. After a call to pnf 337 | -- this will be all the universal quantifiers, and the skolemization 338 | -- will have already turned all the existential quantifiers into 339 | -- skolem functions. For this reason we can safely convert to any 340 | -- instance of IsPropositional. 341 | specialize :: (IsQuantified fof, JustPropositional pf) => (AtomOf fof -> AtomOf pf) -> fof -> pf 342 | specialize ca fm = 343 | convertToPropositional (error "specialize failure") ca (specialize' fm) 344 | where 345 | specialize' p = foldQuantified qu (\_ _ _ -> p) (\_ -> p) (\_ -> p) (\_ -> p) p 346 | qu (:!:) _ p = specialize' p 347 | qu _ _ _ = fm 348 | 349 | -- | Skolemize and then specialize. Because we know all quantifiers 350 | -- are gone we can convert to any instance of IsPropositional. 351 | skolemize :: (IsFirstOrder formula, JustPropositional pf, HasSkolem function, Monad m, 352 | atom ~ AtomOf formula, 353 | term ~ TermOf atom, 354 | function ~ FunOf term, 355 | VarOf formula ~ SVarOf function) => 356 | (AtomOf formula -> AtomOf pf) -> formula -> StateT (SkolemState function) m pf 357 | skolemize ca fm = (specialize ca . pnf) <$> askolemize fm 358 | 359 | -- | A function type that is an instance of HasSkolem 360 | data Function 361 | = Fn String 362 | | Skolem V Int 363 | deriving (Eq, Ord, Data, Typeable, Read) 364 | 365 | instance IsFunction Function 366 | 367 | instance IsString Function where 368 | fromString = Fn 369 | 370 | instance Show Function where 371 | show = showSkolem 372 | 373 | instance Pretty Function where 374 | pPrint = prettySkolem (\(Fn s) -> text s) 375 | 376 | instance HasSkolem Function where 377 | type SVarOf Function = V 378 | toSkolem = Skolem 379 | foldSkolem _ sk (Skolem v n) = sk v n 380 | foldSkolem other _ f = other f 381 | variantSkolem f fns | Set.notMember f fns = f 382 | variantSkolem (Fn s) fns = variantSkolem (fromString (s ++ "'")) fns 383 | variantSkolem (Skolem v n) fns = variantSkolem (Skolem v (succ n)) fns 384 | 385 | -- | A first order logic formula type with an equality predicate and skolem functions. 386 | type Formula = QFormula V SkAtom 387 | type SkAtom = FOL Predicate SkTerm 388 | type SkTerm = Term Function V 389 | 390 | instance IsFirstOrder Formula 391 | 392 | test04 :: Test 393 | test04 = TestCase $ assertEqual "skolemize 1 (p. 150)" expected input 394 | where input = runSkolem (skolemize id fm) :: PFormula SkAtom 395 | fm :: Formula 396 | fm = exists "y" (pApp ("<") [vt "x", vt "y"] .=>. 397 | for_all "u" (exists "v" (pApp ("<") [fApp "*" [vt "x", vt "u"], fApp "*" [vt "y", vt "v"]]))) 398 | expected = ((.~.)(pApp ("<") [vt "x",fApp (Skolem "y" 1) [vt "x"]])) .|. 399 | (pApp ("<") [fApp "*" [vt "x",vt "u"],fApp "*" [fApp (Skolem "y" 1) [vt "x"],fApp (Skolem "v" 1) [vt "u",vt "x"]]]) 400 | 401 | test05 :: Test 402 | test05 = TestCase $ assertEqual "skolemize 2 (p. 150)" expected input 403 | where p = "P" 404 | q = "Q" 405 | input = runSkolem (skolemize id fm) :: PFormula SkAtom 406 | fm :: Formula 407 | fm = for_all "x" ((pApp p [vt "x"]) .=>. 408 | (exists "y" (exists "z" ((pApp q [vt "y"]) .|. 409 | ((.~.)(exists "z" ((pApp p [vt "z"]) .&. (pApp q [vt "z"])))))))) 410 | expected = ((.~.)(pApp p [vt "x"])) .|. 411 | ((pApp q [fApp (Skolem "y" 1) []]) .|. 412 | (((.~.)(pApp p [vt "z"])) .|. 413 | ((.~.)(pApp q [vt "z"])))) 414 | 415 | -- | Versions of the normal form functions that leave quantifiers in place. 416 | simpdnf' :: (IsFirstOrder fof, Ord fof, 417 | atom ~ AtomOf fof, term ~ TermOf atom, function ~ FunOf term, 418 | v ~ VarOf fof, v ~ TVarOf term) => 419 | fof -> Set (Set fof) 420 | simpdnf' fm = 421 | foldQuantified (\_ _ _ -> go) (\_ _ _ -> go) (\_ -> go) tf (\_ -> go) fm 422 | where 423 | tf False = Set.empty 424 | tf True = Set.singleton Set.empty 425 | go = let djs = Set.filter (not . trivial) (purednf' (nnf fm)) in 426 | Set.filter (\d -> not (setAny (\d' -> Set.isProperSubsetOf d' d) djs)) djs 427 | 428 | purednf' :: (IsQuantified fof, Ord fof) => fof -> Set (Set fof) 429 | purednf' fm = 430 | {-t4 $-} 431 | foldPropositional' ho co (\_ -> lf fm) (\_ -> lf fm) (\_ -> lf fm) ({-t3-} fm) 432 | where 433 | lf = Set.singleton . Set.singleton 434 | ho _ = lf fm 435 | co p (:&:) q = distrib (purednf' p) (purednf' q) 436 | co p (:|:) q = union (purednf' p) (purednf' q) 437 | co _ _ _ = lf fm 438 | -- t3 x = trace ("purednf' (" ++ prettyShow x) x 439 | -- t4 x = trace ("purednf' (" ++ prettyShow fm ++ ") -> " ++ prettyShow x) x 440 | 441 | simpcnf' :: (atom ~ AtomOf fof, term ~ TermOf atom, predicate ~ PredOf atom, v ~ VarOf fof, v ~ TVarOf term, function ~ FunOf term, 442 | IsFirstOrder fof, Ord fof) => fof -> Set (Set fof) 443 | simpcnf' fm = 444 | foldQuantified (\_ _ _ -> go) (\_ _ _ -> go) (\_ -> go) tf (\_ -> go) fm 445 | where 446 | tf False = Set.empty 447 | tf True = Set.singleton Set.empty 448 | go = let cjs = Set.filter (not . trivial) (purecnf' fm) in 449 | Set.filter (\c -> not (setAny (\c' -> Set.isProperSubsetOf c' c) cjs)) cjs 450 | 451 | purecnf' :: (atom ~ AtomOf fof, term ~ TermOf atom, predicate ~ PredOf atom, v ~ VarOf fof, v ~ TVarOf term, function ~ FunOf term, 452 | IsFirstOrder fof, Ord fof) => fof -> Set (Set fof) 453 | purecnf' fm = Set.map (Set.map negate) (purednf' (nnf ((.~.) fm))) 454 | 455 | testSkolem :: Test 456 | testSkolem = TestLabel "Skolem" (TestList [test01, test02, test03, test04, test05]) 457 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/Term.hs: -------------------------------------------------------------------------------- 1 | -- | A Term is a expression representing a domain element. It is 2 | -- composed of variables which can be bound to domain elements, or 3 | -- functions which can be applied to terms to yield other domain 4 | -- elements. 5 | 6 | {-# LANGUAGE DeriveDataTypeable #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE FunctionalDependencies #-} 10 | {-# LANGUAGE GADTs #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# LANGUAGE OverloadedStrings #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | 19 | module Data.Logic.ATP.Term 20 | ( -- * Variables 21 | IsVariable(variant, prefix) 22 | , variants 23 | --, showVariable 24 | , V(V) 25 | -- * Functions 26 | , IsFunction 27 | , Arity 28 | , FName(FName) 29 | -- * Terms 30 | , IsTerm(TVarOf, FunOf, vt, fApp, foldTerm) 31 | , zipTerms 32 | , convertTerm 33 | , precedenceTerm 34 | , associativityTerm 35 | , prettyTerm 36 | , prettyFunctionApply 37 | , showTerm 38 | , showFunctionApply 39 | , funcs 40 | , Term(Var, FApply) 41 | , FTerm 42 | , testTerm 43 | ) where 44 | 45 | import Data.Data (Data) 46 | import Data.Logic.ATP.Pretty ((<>), Associativity(InfixN), Doc, HasFixity(associativity, precedence), Precedence, prettyShow, text) 47 | import Data.Set as Set (empty, insert, member, Set, singleton) 48 | import Data.String (IsString(fromString)) 49 | import Data.Typeable (Typeable) 50 | import Prelude hiding (pred) 51 | import Text.PrettyPrint (parens, brackets, punctuate, comma, fsep, space) 52 | import Text.PrettyPrint.HughesPJClass (maybeParens, Pretty(pPrint, pPrintPrec), PrettyLevel, prettyNormal) 53 | import Test.HUnit 54 | 55 | --------------- 56 | -- VARIABLES -- 57 | --------------- 58 | 59 | class (Ord v, IsString v, Pretty v, Show v) => IsVariable v where 60 | variant :: v -> Set v -> v 61 | -- ^ Return a variable based on v but different from any set 62 | -- element. The result may be v itself if v is not a member of 63 | -- the set. 64 | prefix :: String -> v -> v 65 | -- ^ Modify a variable by adding a prefix. This unfortunately 66 | -- assumes that v is "string-like" but at least one algorithm in 67 | -- Harrison currently requires this. 68 | 69 | -- | Return an infinite list of variations on v 70 | variants :: IsVariable v => v -> [v] 71 | variants v0 = 72 | loop Set.empty v0 73 | where loop s v = let v' = variant v s in v' : loop (Set.insert v s) v' 74 | 75 | -- | Because IsString is a superclass we can just output a string expression 76 | showVariable :: IsVariable v => v -> String 77 | showVariable v = show (prettyShow v) 78 | 79 | newtype V = V String deriving (Eq, Ord, Data, Typeable, Read) 80 | 81 | instance IsVariable String where 82 | variant v vs = if Set.member v vs then variant (v ++ "'") vs else v 83 | prefix pre s = pre ++ s 84 | 85 | instance IsVariable V where 86 | variant v@(V s) vs = if Set.member v vs then variant (V (s ++ "'")) vs else v 87 | prefix pre (V s) = V (pre ++ s) 88 | 89 | instance IsString V where 90 | fromString = V 91 | 92 | instance Show V where 93 | show (V s) = show s 94 | 95 | instance Pretty V where 96 | pPrint (V s) = text s 97 | 98 | --------------- 99 | -- FUNCTIONS -- 100 | --------------- 101 | 102 | class (IsString function, Ord function, Pretty function, Show function) => IsFunction function 103 | 104 | type Arity = Int 105 | 106 | -- | A simple type to use as the function parameter of Term. The only 107 | -- reason to use this instead of String is to get nicer pretty 108 | -- printing. 109 | newtype FName = FName String deriving (Eq, Ord) 110 | 111 | instance IsFunction FName 112 | 113 | instance IsString FName where fromString = FName 114 | 115 | instance Show FName where show (FName s) = s 116 | 117 | instance Pretty FName where pPrint (FName s) = text s 118 | 119 | ----------- 120 | -- TERMS -- 121 | ----------- 122 | 123 | -- | A term is an expression representing a domain element, either as 124 | -- a variable reference or a function applied to a list of terms. 125 | class (Eq term, Ord term, Pretty term, Show term, IsString term, HasFixity term, 126 | IsVariable (TVarOf term), IsFunction (FunOf term)) => IsTerm term where 127 | type TVarOf term 128 | -- ^ The associated variable type 129 | type FunOf term 130 | -- ^ The associated function type 131 | vt :: TVarOf term -> term 132 | -- ^ Build a term which is a variable reference. 133 | fApp :: FunOf term -> [term] -> term 134 | -- ^ Build a term by applying terms to an atomic function ('FunOf' @term@). 135 | foldTerm :: (TVarOf term -> r) -- ^ Variable references are dispatched here 136 | -> (FunOf term -> [term] -> r) -- ^ Function applications are dispatched here 137 | -> term -> r 138 | -- ^ A fold over instances of 'IsTerm'. 139 | 140 | -- | Combine two terms if they are similar (i.e. two variables or 141 | -- two function applications.) 142 | zipTerms :: (IsTerm term1, v1 ~ TVarOf term1, function1 ~ FunOf term1, 143 | IsTerm term2, v2 ~ TVarOf term2, function2 ~ FunOf term2) => 144 | (v1 -> v2 -> Maybe r) -- ^ Combine two variables 145 | -> (function1 -> [term1] -> function2 -> [term2] -> Maybe r) -- ^ Combine two function applications 146 | -> term1 147 | -> term2 148 | -> Maybe r -- ^ Result for dissimilar terms is 'Nothing'. 149 | zipTerms v ap t1 t2 = 150 | foldTerm v' ap' t1 151 | where 152 | v' v1 = foldTerm (v v1) (\_ _ -> Nothing) t2 153 | ap' p1 ts1 = foldTerm (\_ -> Nothing) (\p2 ts2 -> if length ts1 == length ts2 then ap p1 ts1 p2 ts2 else Nothing) t2 154 | 155 | -- | Convert between two instances of IsTerm 156 | convertTerm :: (IsTerm term1, v1 ~ TVarOf term1, f1 ~ FunOf term1, 157 | IsTerm term2, v2 ~ TVarOf term2, f2 ~ FunOf term2) => 158 | (v1 -> v2) -- ^ convert a variable 159 | -> (f1 -> f2) -- ^ convert a function 160 | -> term1 -> term2 161 | convertTerm cv cf = foldTerm (vt . cv) (\f ts -> fApp (cf f) (map (convertTerm cv cf) ts)) 162 | 163 | precedenceTerm :: IsTerm term => term -> Precedence 164 | precedenceTerm = const 0 165 | 166 | associativityTerm :: IsTerm term => term -> Associativity 167 | associativityTerm = const InfixN 168 | 169 | -- | Implementation of pPrint for any term 170 | prettyTerm :: (v ~ TVarOf term, function ~ FunOf term, IsTerm term, HasFixity term, Pretty v, Pretty function) => 171 | PrettyLevel -> Rational -> term -> Doc 172 | prettyTerm l r tm = maybeParens (l > prettyNormal || r > precedence tm) (foldTerm pPrint (prettyFunctionApply l) tm) 173 | 174 | -- | Format a function application: F(x,y) 175 | prettyFunctionApply :: (function ~ FunOf term, IsTerm term, HasFixity term) => PrettyLevel -> function -> [term] -> Doc 176 | prettyFunctionApply _l f [] = pPrint f 177 | prettyFunctionApply l f ts = pPrint f <> parens (fsep (punctuate comma (map (prettyTerm l 0) ts))) 178 | 179 | -- | Implementation of show for any term 180 | showTerm :: (v ~ TVarOf term, function ~ FunOf term, IsTerm term, Pretty v, Pretty function) => term -> String 181 | showTerm = foldTerm showVariable showFunctionApply 182 | 183 | -- | Build an expression for a function application: fApp (F) [x, y] 184 | showFunctionApply :: (v ~ TVarOf term, function ~ FunOf term, IsTerm term) => function -> [term] -> String 185 | showFunctionApply f ts = "fApp (" <> show f <> ")" <> show (brackets (fsep (punctuate (comma <> space) (map (text . show) ts)))) 186 | 187 | funcs :: (IsTerm term, function ~ FunOf term) => term -> Set (function, Arity) 188 | funcs = foldTerm (\_ -> Set.empty) (\f ts -> Set.singleton (f, length ts)) 189 | 190 | data Term function v 191 | = Var v 192 | | FApply function [Term function v] 193 | deriving (Eq, Ord, Data, Typeable, Read) 194 | 195 | instance (IsVariable v, IsFunction function) => IsString (Term function v) where 196 | fromString = Var . fromString 197 | 198 | instance (IsVariable v, IsFunction function) => Show (Term function v) where 199 | show = showTerm 200 | 201 | instance (IsFunction function, IsVariable v) => HasFixity (Term function v) where 202 | precedence = precedenceTerm 203 | associativity = associativityTerm 204 | 205 | instance (IsFunction function, IsVariable v) => IsTerm (Term function v) where 206 | type TVarOf (Term function v) = v 207 | type FunOf (Term function v) = function 208 | vt = Var 209 | fApp = FApply 210 | foldTerm vf fn t = 211 | case t of 212 | Var v -> vf v 213 | FApply f ts -> fn f ts 214 | 215 | instance (IsTerm (Term function v)) => Pretty (Term function v) where 216 | pPrintPrec = prettyTerm 217 | 218 | -- | A term type with no Skolem functions 219 | type FTerm = Term FName V 220 | 221 | -- Example. 222 | test00 :: Test 223 | test00 = TestCase $ assertEqual "print an expression" 224 | "sqrt(-(1, cos(power(+(x, y), 2))))" 225 | (prettyShow (fApp "sqrt" [fApp "-" [fApp "1" [], 226 | fApp "cos" [fApp "power" [fApp "+" [Var "x", Var "y"], 227 | fApp "2" []]]]] :: Term FName V)) 228 | 229 | testTerm :: Test 230 | testTerm = TestLabel "Term" (TestList [test00]) 231 | -------------------------------------------------------------------------------- /src/Data/Logic/ATP/Unif.hs: -------------------------------------------------------------------------------- 1 | -- | Unification for first order terms. 2 | -- 3 | -- Copyright (c) 2003-2007, John Harrison. (See "LICENSE.txt" for details.) 4 | 5 | {-# OPTIONS -Wall #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | module Data.Logic.ATP.Unif 15 | ( Unify(unify', UTermOf) 16 | , unify 17 | , unify_terms 18 | , unify_literals 19 | , unify_atoms 20 | , unify_atoms_eq 21 | , solve 22 | , fullunify 23 | , unify_and_apply 24 | , testUnif 25 | ) where 26 | 27 | import Control.Monad.State hiding (fail) -- (evalStateT, runStateT, State, StateT, get) 28 | import Prelude hiding (fail) 29 | import Control.Monad.Fail 30 | import Data.Bool (bool) 31 | import Data.List as List (map) 32 | import Data.Logic.ATP.Apply (HasApply(TermOf, PredOf), JustApply, zipApplys) 33 | import Data.Logic.ATP.Equate (HasEquate, zipEquates) 34 | import Data.Logic.ATP.FOL (tsubst) 35 | import Data.Logic.ATP.Formulas (IsFormula(AtomOf)) 36 | import Data.Logic.ATP.Lib (Failing(Success, Failure)) 37 | import Data.Logic.ATP.Lit (IsLiteral, JustLiteral, zipLiterals') 38 | import Data.Logic.ATP.Skolem (SkAtom, SkTerm) 39 | import Data.Logic.ATP.Term (IsTerm(..), IsVariable) 40 | import Data.Map.Strict as Map 41 | import Data.Maybe (fromMaybe) 42 | -- import Data.Sequence (Seq, viewl, ViewL(EmptyL, (:<))) 43 | import Test.HUnit hiding (State) 44 | 45 | -- | Main unification procedure. The result of unification is a 46 | -- mapping of variables to terms, so although we can unify two 47 | -- dissimilar types, they must at least have the same term type (which 48 | -- means the variable type will also match.) The result of unifying 49 | -- the two arguments is added to the state, while failure is signalled 50 | -- in the Failing monad. 51 | -- 52 | -- One might think that Unify should take two type parameters, the 53 | -- types of two values to be unified, but there are instances where a 54 | -- single type contains both - for example, in template-haskell we 55 | -- want to unify a and b in a predicate such as this: @(AppT (AppT 56 | -- EqualityT a) b)@. 57 | class (Monad m, IsTerm (UTermOf a), IsVariable (TVarOf (UTermOf a))) => Unify m a where 58 | type UTermOf a 59 | unify' :: a -> StateT (Map (TVarOf (UTermOf a)) (UTermOf a)) m () 60 | 61 | unify :: (Unify m a, Monad m) => a -> Map (TVarOf (UTermOf a)) (UTermOf a) -> m (Map (TVarOf (UTermOf a)) (UTermOf a)) 62 | unify a mp0 = execStateT (unify' a) mp0 63 | 64 | unify_terms :: (IsTerm term, v ~ TVarOf term, MonadFail m) => 65 | [(term,term)] -> StateT (Map v term) m () 66 | unify_terms = mapM_ (uncurry unify_term_pair) 67 | 68 | unify_term_pair :: forall term v f m. 69 | (IsTerm term, v ~ TVarOf term, f ~ FunOf term, MonadFail m) => 70 | term -> term -> StateT (Map v term) m () 71 | unify_term_pair a b = 72 | foldTerm (vr b) (\ f fargs -> foldTerm (vr a) (fn f fargs) b) a 73 | where 74 | vr :: term -> v -> StateT (Map v term) m () 75 | vr t x = 76 | (Map.lookup x <$> get) >>= 77 | maybe (istriv x t >>= bool (modify (Map.insert x t)) (return ())) 78 | (\y -> unify_term_pair y t) 79 | fn :: f -> [term] -> f -> [term] -> StateT (Map v term) m () 80 | fn f fargs g gargs = 81 | if f == g && length fargs == length gargs 82 | then mapM_ (uncurry unify_term_pair) (zip fargs gargs) 83 | else fail "impossible unification" 84 | 85 | istriv :: forall term v f m. (IsTerm term, v ~ TVarOf term, f ~ FunOf term, MonadFail m) => 86 | v -> term -> StateT (Map v term) m Bool 87 | istriv x t = 88 | foldTerm vr fn t 89 | where 90 | vr :: v -> StateT (Map v term) m Bool 91 | vr y | x == y = return True 92 | vr y = (Map.lookup y <$> get) >>= \(mt :: Maybe term) -> maybe (return False) (istriv x) mt 93 | fn :: f -> [term] -> StateT (Map v term) m Bool 94 | fn _ args = mapM (istriv x) args >>= bool (return False) (fail "cyclic") . or 95 | 96 | -- | Solve to obtain a single instantiation. 97 | solve :: (IsTerm term, v ~ TVarOf term) => 98 | Map v term -> Map v term 99 | solve env = 100 | if env' == env then env else solve env' 101 | where env' = Map.map (tsubst env) env 102 | 103 | -- | Unification reaching a final solved form (often this isn't needed). 104 | fullunify :: (IsTerm term, v ~ TVarOf term, f ~ FunOf term, MonadFail m) => 105 | [(term,term)] -> m (Map v term) 106 | fullunify eqs = solve <$> execStateT (unify_terms eqs) Map.empty 107 | 108 | -- | Examples. 109 | unify_and_apply :: (IsTerm term, v ~ TVarOf term, f ~ FunOf term, MonadFail m) => 110 | [(term, term)] -> m [(term, term)] 111 | unify_and_apply eqs = 112 | fullunify eqs >>= \i -> return $ List.map (\ (t1, t2) -> (tsubst i t1, tsubst i t2)) eqs 113 | 114 | -- | Unify literals, perhaps of different types, but sharing term and 115 | -- variable type. Note that only one needs to be 'JustLiteral', if 116 | -- the unification succeeds the other must have been too, if it fails, 117 | -- who cares. 118 | unify_literals :: forall lit1 lit2 atom1 atom2 v term m. 119 | (IsLiteral lit1, HasApply atom1, atom1 ~ AtomOf lit1, term ~ TermOf atom1, 120 | JustLiteral lit2, HasApply atom2, atom2 ~ AtomOf lit2, term ~ TermOf atom2, 121 | Unify m (atom1, atom2), term ~ UTermOf (atom1, atom2), v ~ TVarOf term, 122 | MonadFail m) => 123 | lit1 -> lit2 -> StateT (Map v term) m () 124 | unify_literals f1 f2 = 125 | fromMaybe (fail "Can't unify literals") (zipLiterals' ho ne tf at f1 f2) 126 | where 127 | ho _ _ = Nothing 128 | ne p q = Just $ unify_literals p q 129 | -- tf :: Bool -> Bool -> Maybe (StateT (Map v term) m ()) 130 | tf p q = if p == q then Just (unify_terms ([] :: [(term, term)])) else Nothing 131 | at a1 a2 = Just (unify' (a1, a2)) 132 | 133 | unify_atoms :: (JustApply atom1, term ~ TermOf atom1, 134 | JustApply atom2, term ~ TermOf atom2, 135 | v ~ TVarOf term, PredOf atom1 ~ PredOf atom2, MonadFail m) => 136 | (atom1, atom2) -> StateT (Map v term) m () 137 | unify_atoms (a1, a2) = 138 | maybe (fail "unify_atoms") id (zipApplys (\_ tpairs -> Just (unify_terms tpairs)) a1 a2) 139 | 140 | unify_atoms_eq :: (HasEquate atom1, term ~ TermOf atom1, 141 | HasEquate atom2, term ~ TermOf atom2, 142 | PredOf atom1 ~ PredOf atom2, v ~ TVarOf term, MonadFail m) => 143 | atom1 -> atom2 -> StateT (Map v term) m () 144 | unify_atoms_eq a1 a2 = 145 | maybe (fail "unify_atoms") id (zipEquates (\l1 r1 l2 r2 -> Just (unify_terms [(l1, l2), (r1, r2)])) 146 | (\_ tpairs -> Just (unify_terms tpairs)) 147 | a1 a2) 148 | 149 | --unify_and_apply' :: (v ~ TVarOf term, f ~ FunOf term, IsTerm term, Monad m) => [(term, term)] -> m [(term, term)] 150 | --unify_and_apply' eqs = 151 | -- mapM app eqs 152 | -- where 153 | -- app (t1, t2) = fullunify eqs >>= \i -> return $ (tsubst i t1, tsubst i t2) 154 | 155 | instance MonadFail m => Unify m (SkAtom, SkAtom) where 156 | type UTermOf (SkAtom, SkAtom) = TermOf SkAtom 157 | unify' = uncurry unify_atoms_eq 158 | 159 | test01, test02, test03, test04 :: Test 160 | test01 = TestCase (assertEqual "Unify test 1" 161 | (Success [(f [f [z],g [y]], 162 | f [f [z],g [y]])]) -- expected 163 | (unify_and_apply [(f [x, g [y]], f [f [z], w])])) 164 | where 165 | [f, g] = [fApp "f", fApp "g"] 166 | [w, x, y, z] = [vt "w", vt "x", vt "y", vt "z"] :: [SkTerm] 167 | test02 = TestCase (assertEqual "Unify test 2" 168 | (Success [(f [y,y], 169 | f [y,y])]) -- expected 170 | (unify_and_apply [(f [x, y], f [y, x])])) 171 | where 172 | [f] = [fApp "f"] 173 | [x, y] = [vt "x", vt "y"] :: [SkTerm] 174 | test03 = TestCase (assertEqual "Unify test 3" 175 | (Failure ["cyclic"]) -- expected 176 | (unify_and_apply [(f [x, g [y]], f [y, x])])) 177 | where 178 | [f, g] = [fApp "f", fApp "g"] 179 | [x, y] = [vt "x", vt "y"] :: [SkTerm] 180 | test04 = TestCase (assertEqual "Unify test 4" 181 | (Success [(f [f [f [x_3,x_3],f [x_3,x_3]], f [f [x_3,x_3],f [x_3,x_3]]], 182 | f [f [f [x_3,x_3],f [x_3,x_3]], f [f [x_3,x_3],f [x_3,x_3]]]), 183 | (f [f [x_3,x_3],f [x_3,x_3]], 184 | f [f [x_3,x_3],f [x_3,x_3]]), 185 | (f [x_3,x_3], 186 | f [x_3,x_3])]) -- expected 187 | (unify_and_apply [(x_0, f [x_1, x_1]), 188 | (x_1, f [x_2, x_2]), 189 | (x_2, f [x_3, x_3])])) 190 | 191 | where 192 | f = fApp "f" 193 | [x_0, x_1, x_2, x_3] = [vt "x0", vt "x1", vt "x2", vt "x3"] :: [SkTerm] 194 | {- 195 | 196 | START_INTERACTIVE;; 197 | unify_and_apply [<<|f(x,g(y))|>>,<<|f(f(z),w)|>>];; 198 | 199 | unify_and_apply [<<|f(x,y)|>>,<<|f(y,x)|>>];; 200 | 201 | (**** unify_and_apply [<<|f(x,g(y))|>>,<<|f(y,x)|>>];; *****) 202 | 203 | unify_and_apply [<<|x_0|>>,<<|f(x_1,x_1)|>>; 204 | <<|x_1|>>,<<|f(x_2,x_2)|>>; 205 | <<|x_2|>>,<<|f(x_3,x_3)|>>];; 206 | END_INTERACTIVE;; 207 | -} 208 | 209 | testUnif :: Test 210 | testUnif = TestLabel "Unif" (TestList [test01, test02, test03, test04]) 211 | -------------------------------------------------------------------------------- /tests/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, MultiParamTypeClasses, OverloadedStrings, QuasiQuotes, ScopedTypeVariables, TemplateHaskell #-} 2 | module Extra where 3 | 4 | import Data.List as List (map) 5 | import Data.Logic.ATP.Apply (pApp) 6 | import Data.Logic.ATP.Equate ((.=.)) 7 | import Data.Logic.ATP.Formulas 8 | import Data.Logic.ATP.Lib (Depth(Depth), Failing(Failure, Success)) 9 | import Data.Logic.ATP.Lit ((.~.)) 10 | import Data.Logic.ATP.Meson (meson) 11 | import Data.Logic.ATP.Pretty (prettyShow, testEquals) 12 | import Data.Logic.ATP.Prop hiding (nnf) 13 | import Data.Logic.ATP.Quantified (for_all, exists) 14 | import Data.Logic.ATP.Parser (fof) 15 | import Data.Logic.ATP.Resolution 16 | import Data.Logic.ATP.Skolem (Formula, HasSkolem(toSkolem), skolemize, runSkolem, SkAtom, SkTerm) 17 | import Data.Logic.ATP.Tableaux (K(K), tab) 18 | import Data.Logic.ATP.Term (vt, fApp) 19 | import Data.Map as Map (empty) 20 | import Data.Set as Set (fromList, minView, null, Set, singleton) 21 | import Data.String (fromString) 22 | import Test.HUnit 23 | 24 | testExtra :: Test 25 | testExtra = TestList [test01, test02, test05, test06, test07] 26 | 27 | test05 :: Test 28 | test05 = TestLabel "Socrates syllogism" $ TestCase $ assertEqual "Socrates syllogism" expected input 29 | where input = (runSkolem (resolution1 socrates), 30 | runSkolem (resolution2 socrates), 31 | runSkolem (resolution3 socrates), 32 | runSkolem (presolution socrates), 33 | runSkolem (resolution1 notSocrates), 34 | runSkolem (resolution2 notSocrates), 35 | runSkolem (resolution3 notSocrates), 36 | runSkolem (presolution notSocrates)) 37 | expected = (Set.singleton (Success True), 38 | Set.singleton (Success True), 39 | Set.singleton (Success True), 40 | Set.singleton (Success True), 41 | Set.singleton (Success {-False-} True), 42 | Set.singleton (Success {-False-} True), 43 | Set.singleton (Failure ["No proof found"]), 44 | Set.singleton (Success {-False-} True)) 45 | 46 | socrates :: Formula 47 | socrates = 48 | (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]) 49 | where 50 | x = fromString "x" 51 | s = pApp (fromString "S") 52 | h = pApp (fromString "H") 53 | m = pApp (fromString "M") 54 | 55 | notSocrates :: Formula 56 | notSocrates = 57 | (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]))) 58 | where 59 | x = fromString "x" 60 | s = pApp (fromString "S") 61 | h = pApp (fromString "H") 62 | m = pApp (fromString "M") 63 | 64 | test06 :: Test 65 | test06 = 66 | let fm :: Formula 67 | fm = for_all "x" (vt "x" .=. vt "x") .=>. for_all "x" (exists "y" (vt "x" .=. vt "y")) 68 | expected :: PFormula SkAtom 69 | expected = (vt "x" .=. vt "x") .&. (.~.) (fApp (toSkolem "x" 1) [] .=. vt "x") 70 | -- atoms = [applyPredicate equals [(vt ("x" :: V)) (vt "x")] {-, (fApp (toSkolem "x" 1)[]) .=. (vt "x")-}] :: [SkAtom] 71 | sk = runSkolem (skolemize id ((.~.) fm)) :: PFormula SkAtom 72 | table = truthTable sk :: TruthTable SkAtom in 73 | TestLabel "∀x. x = x ⇒ ∀x. ∃y. x = y" $ TestCase $ assertEqual "∀x. x = x ⇒ ∀x. ∃y. x = y" 74 | (expected, 75 | TruthTable 76 | (List.map asAtom ([vt "x" .=. vt "x", fApp (toSkolem "x" 1) [] .=. vt "x"] :: [Formula])) 77 | [([False,False],False), 78 | ([False,True],False), 79 | ([True,False],True), 80 | ([True,True],False)] :: TruthTable SkAtom, 81 | Set.fromList [Success (Depth 1)]) 82 | (sk, table, runSkolem (meson Nothing fm)) 83 | 84 | asAtom :: forall formula. IsFormula formula => formula -> AtomOf formula 85 | asAtom fm = case Set.minView (atom_union singleton fm :: Set (AtomOf formula)) of 86 | Just (a, s) | Set.null s -> a 87 | _ -> error "asAtom" 88 | 89 | mesonTest :: (String, Formula, Set (Failing Depth)) -> Test 90 | mesonTest (label, fm, expected) = 91 | let me = runSkolem (meson (Just (Depth 1000)) fm) in 92 | TestLabel label $ TestCase $ assertEqual ("MESON test: " ++ prettyShow fm) expected me 93 | 94 | fms :: [(String, Formula, Set (Failing Depth))] 95 | fms = [ let [x, y] = [vt "x", vt "y"] :: [SkTerm] in 96 | ("if x every x equals itself then there is always some y that equals x", 97 | for_all "x" (x .=. x) .=>. for_all "x" (exists "y" (x .=. y)), 98 | Set.fromList [Success (Depth 1)]), 99 | let x = vt "x" :: SkTerm 100 | [s, h, m] = [pApp "S", pApp "H", pApp "M"] :: [[SkTerm] -> Formula] in 101 | ("Socrates is a human, all humans are mortal, therefore socrates is mortal", 102 | (for_all "x" (s [x] .=>. h [x]) .&. for_all "x" (h [x] .=>. m [x])) .=>. for_all "x" (s [x] .=>. m [x]), 103 | Set.fromList [Success (Depth 3)]) ] 104 | 105 | test07 :: Test 106 | test07 = TestList (List.map mesonTest fms) 107 | 108 | test01 :: Test 109 | test01 = let fm1 = [fof| ∀a. ¬(P(a)∧(∀y. (∀z. Q(y)∨R(z))∧¬P(a))) |] :: Formula in 110 | $(testEquals "MESON 1") ([fof| ∀a. ¬(P(a)∧(∀y. (∀z. Q(y)∨R(z))∧¬P(a))) |], Success ((K 2, Map.empty),Depth 2)) 111 | (fm1, tab Nothing fm1) 112 | test02 :: Test 113 | test02 = let fm2 = [fof| ∀a. ¬(P(a)∧¬P(a)∧(∀y z. Q(y)∨R(z))) |] :: Formula in 114 | $(testEquals "MESON 2") ([fof| ∀a. ¬(P(a)∧¬P(a)∧(∀y z. Q(y)∨R(z))) |], Success ((K 0, Map.empty),Depth 0)) 115 | (fm2, tab Nothing fm2) 116 | {- 117 | i = for_all "a" ((.~.)(p[a] .&. (for_all "y" (for_all "z" (q[y] .|. r[z]) .&. (.~.)(p[a]))))) 118 | 119 | a = (for_all "a" ((.~.) (((pApp (fromString "P")["a"]) .&. (for_all "y" (for_all "z" 120 | (((pApp (fromString "Q")["y"]) .|. 121 | (pApp (fromString "R")["z"])) .&. 122 | ((.~.) ((pApp (fromString "P")["a"])))))))))) 123 | b = (for_all "a" ((.~.) (((pApp (fromString "P")["a"]) .&. (for_all "y" ((for_all "z" 124 | ((pApp (fromString "Q")["y"]) .|. 125 | (pApp (fromString "R")["z"]))) .&. 126 | ((.~.) ((pApp (fromString "P")["a"]))))))))) 127 | -} 128 | {- 129 | test12 :: Test 130 | test12 = 131 | 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 132 | TestCase $ assertEqual "∀x. x = x ⇒ ∀x. ∃y. x = y" (holds fm) True 133 | -} 134 | -------------------------------------------------------------------------------- /tests/Main.hs: -------------------------------------------------------------------------------- 1 | import Test.HUnit 2 | 3 | import Data.Logic.ATP.DefCNF (testDefCNF) 4 | import Data.Logic.ATP.DP (testDP) 5 | import Data.Logic.ATP.FOL (testFOL) 6 | import Data.Logic.ATP.Herbrand (testHerbrand) 7 | import Data.Logic.ATP.Lib (testLib) 8 | import Data.Logic.ATP.Prop (testProp) 9 | import Data.Logic.ATP.PropExamples (testPropExamples) 10 | import Data.Logic.ATP.Skolem (testSkolem) 11 | import Data.Logic.ATP.ParserTests (testParser) 12 | import Data.Logic.ATP.Unif (testUnif) 13 | import Data.Logic.ATP.Tableaux (testTableaux) 14 | import Data.Logic.ATP.Resolution (testResolution) 15 | import Data.Logic.ATP.Prolog (testProlog) 16 | import Data.Logic.ATP.Meson (testMeson) 17 | import Data.Logic.ATP.Equal (testEqual) 18 | import Extra (testExtra) 19 | 20 | import System.Exit (exitWith, ExitCode(ExitSuccess, ExitFailure)) 21 | 22 | main :: IO Counts 23 | main = runTestTT (TestList [TestLabel "Lib" testLib, 24 | TestLabel "Prop" testProp, 25 | TestLabel "PropExamples" testPropExamples, 26 | TestLabel "DefCNF" testDefCNF, 27 | TestLabel "DP" testDP, 28 | TestLabel "FOL" testFOL, 29 | TestLabel "Skolem" testSkolem, 30 | TestLabel "Parser" testParser, 31 | TestLabel "Herbrand" testHerbrand, 32 | TestLabel "Unif" testUnif, 33 | TestLabel "Tableaux" testTableaux, 34 | TestLabel "Resolution" testResolution, 35 | TestLabel "Prolog" testProlog, 36 | TestLabel "Meson" testMeson, 37 | TestLabel "Equal" testEqual, 38 | TestLabel "Extra" testExtra 39 | ]) >>= doCounts 40 | where 41 | doCounts counts' = exitWith (if errors counts' /= 0 || failures counts' /= 0 then ExitFailure 1 else ExitSuccess) 42 | --------------------------------------------------------------------------------