├── .travis.yml ├── Setup.hs ├── .gitignore ├── LICENSE ├── execs └── Main.hs ├── WangsAlgorithm.cabal ├── src └── WangsAlgorithm │ ├── Parser.hs │ ├── Proposition.hs │ ├── LaTeX.hs │ └── Prover.hs ├── stack.yaml ├── tests └── tests.hs └── README.md /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | ghc: 7.8.3 3 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virtualenv 8 | .hsenv 9 | .cabal-sandbox/ 10 | cabal.sandbox.config 11 | cabal.config 12 | .stack-work 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Joomy Korkut 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /execs/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Main where 3 | 4 | import WangsAlgorithm.Prover 5 | import WangsAlgorithm.LaTeX (latexProof) 6 | import qualified WangsAlgorithm.Parser as P 7 | import Options.Applicative 8 | import Data.Semigroup ((<>)) 9 | 10 | data Backend = 11 | Text 12 | | LaTeX 13 | deriving (Show, Eq, Read, Enum, Bounded) 14 | 15 | allBackends :: [Backend] 16 | allBackends = enumFrom minBound 17 | 18 | data Input = Input 19 | { sequentStr :: String 20 | , backend :: Backend 21 | } 22 | 23 | getInput :: Parser Input 24 | getInput = Input 25 | <$> strOption 26 | ( long "sequent" 27 | <> short 's' 28 | <> metavar "SEQUENT" 29 | <> help "The propositional logic sequent to be proved" ) 30 | <*> option auto 31 | ( long "backend" 32 | <> short 'b' 33 | <> value Text 34 | <> help ("Select one of " ++ show allBackends)) 35 | 36 | run :: Input -> IO () 37 | run Input{..} = case P.readSequent sequentStr of 38 | Left err -> error $ "Cannot be parsed: " ++ show err 39 | Right sequent -> case prove sequent of 40 | Nothing -> error "No possible moves." 41 | Just pf -> case backend of 42 | Text -> putStrLn $ showProof pf 43 | LaTeX -> putStrLn $ latexProof pf 44 | 45 | main :: IO () 46 | main = run =<< execParser opts 47 | where 48 | opts = info (getInput <**> helper) 49 | ( fullDesc 50 | <> progDesc ("Enter your sequent in the following format: " 51 | ++ "[a|b, a&c, ~b, c->d] |- [b,c]") 52 | <> header "A propositional theorem prover for LK using Wang's Algorithm") 53 | -------------------------------------------------------------------------------- /WangsAlgorithm.cabal: -------------------------------------------------------------------------------- 1 | name: WangsAlgorithm 2 | version: 0.1.0.0 3 | synopsis: A Propositional Theorem Prover using Wang's Algorithm 4 | homepage: http://github.com/joom/WangsAlgorithm 5 | license: MIT 6 | license-file: LICENSE 7 | author: Joomy Korkut 8 | maintainer: cumhurkorkut@gmail.com 9 | category: Math 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable wang 14 | default-extensions: OverloadedStrings 15 | main-is: Main.hs 16 | build-depends: base >=4.7 17 | , parsec >= 3 18 | , optparse-applicative 19 | , HaTeX 20 | , WangsAlgorithm 21 | hs-source-dirs: execs 22 | default-language: Haskell2010 23 | 24 | library 25 | default-extensions: OverloadedStrings 26 | exposed-modules: WangsAlgorithm.Proposition 27 | , WangsAlgorithm.Prover 28 | , WangsAlgorithm.Parser 29 | , WangsAlgorithm.LaTeX 30 | build-depends: base 31 | , parsec >= 3 32 | , HaTeX >= 3 33 | hs-source-dirs: src 34 | default-language: Haskell2010 35 | ghc-options: -Wall -threaded 36 | 37 | test-suite tests 38 | default-extensions: OverloadedStrings 39 | type: exitcode-stdio-1.0 40 | hs-source-dirs: tests 41 | main-is: tests.hs 42 | build-depends: base 43 | , WangsAlgorithm 44 | , HUnit >= 1.2.5.0 45 | , QuickCheck >= 2 46 | Default-Language: Haskell2010 47 | ghc-options: -Wall -threaded 48 | -------------------------------------------------------------------------------- /src/WangsAlgorithm/Parser.hs: -------------------------------------------------------------------------------- 1 | module WangsAlgorithm.Parser where 2 | 3 | import WangsAlgorithm.Proposition 4 | 5 | import Text.ParserCombinators.Parsec 6 | import Text.ParserCombinators.Parsec.Expr 7 | import Data.Char (isSpace) 8 | 9 | parseProp :: Parser Proposition 10 | parseProp = buildExpressionParser operators factor "Proposition" 11 | where 12 | factor = do { _ <- char '(' ; x <- parseProp ; _ <- char ')' ; return x } 13 | <|> fmap Atom (many1 letter) 14 | "Proposition" 15 | operators = [ unaries Not ["~", "-", "¬"] 16 | , binaries And ["&", "^", "∧"] 17 | , binaries Or ["|", "∨"] 18 | , binaries Implies ["->", "⊃", "→"] ] 19 | unary c n = Prefix . chainl1 (string n >> return c) $ return (.) 20 | binary c n = Infix (string n >> return c) AssocRight 21 | unaries c = map (unary c) 22 | binaries c = map (binary c) 23 | 24 | -- | Parses prop list without the brackets. 25 | parseProps :: Parser [Proposition] 26 | parseProps = do { 27 | first <- parseProp 28 | ; next <- (char ',' >> parseProps) <|> return [] 29 | ; return (first : next) } <|> return [] 30 | 31 | -- | Parses prop list with the brackets. 32 | parsePropList :: Parser [Proposition] 33 | parsePropList = do 34 | _ <- char '[' 35 | l <- parseProps 36 | _ <- char ']' 37 | return l 38 | 39 | parseSequent :: Parser Sequent 40 | parseSequent = do 41 | lefts <- parsePropList 42 | _ <- (char '|' >> char '-') <|> char '⊢' 43 | rights <- parsePropList 44 | return $ lefts `proves` rights 45 | 46 | readSequent :: String -> Either ParseError Sequent 47 | readSequent s = parse parseSequent "Sequent" (filter (not . isSpace) s) 48 | -------------------------------------------------------------------------------- /src/WangsAlgorithm/Proposition.hs: -------------------------------------------------------------------------------- 1 | module WangsAlgorithm.Proposition where 2 | 3 | data Proposition = Atom {name :: String} 4 | | Not Proposition 5 | | And Proposition Proposition 6 | | Or Proposition Proposition 7 | | Implies Proposition Proposition 8 | deriving Eq 9 | 10 | data Sequent = Sequent [Proposition] [Proposition] 11 | deriving Eq 12 | 13 | -- | A more readable infix alias for Sequent. 14 | proves :: [Proposition] -> [Proposition] -> Sequent 15 | proves = Sequent 16 | 17 | instance Show Proposition where 18 | show (Atom x) = x 19 | show (Not x) = "¬(" ++ show x ++ ")" 20 | show (And x y) = "(" ++ show x ++ ") ∧ (" ++ show y ++ ")" 21 | show (Or x y) = "(" ++ show x ++ ") ∨ (" ++ show y ++ ")" 22 | show (Implies x y) = "(" ++ show x ++ ") ⊃ (" ++ show y ++ ")" 23 | 24 | instance Show Sequent where 25 | show (Sequent x y) = show x ++ " ⊢ " ++ show y 26 | 27 | notProp :: Proposition -> Proposition 28 | notProp (Not x) = x 29 | notProp y = Not y 30 | 31 | andProp :: Proposition -> (Proposition, Proposition) 32 | andProp (And x y) = (x, y) 33 | andProp _ = error "Only works on And." 34 | 35 | orProp :: Proposition -> (Proposition, Proposition) 36 | orProp (Or x y) = (x, y) 37 | orProp _ = error "Only works on Or." 38 | 39 | impProp :: Proposition -> (Proposition, Proposition) 40 | impProp (Implies x y) = (x, y) 41 | impProp _ = error "Only works on Implies." 42 | 43 | isNot :: Proposition -> Bool 44 | isNot (Not _) = True 45 | isNot _ = False 46 | 47 | isAnd :: Proposition -> Bool 48 | isAnd (And _ _) = True 49 | isAnd _ = False 50 | 51 | isOr :: Proposition -> Bool 52 | isOr (Or _ _) = True 53 | isOr _ = False 54 | 55 | isImp :: Proposition -> Bool 56 | isImp (Implies _ _) = True 57 | isImp _ = False 58 | -------------------------------------------------------------------------------- /src/WangsAlgorithm/LaTeX.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module WangsAlgorithm.LaTeX where 3 | 4 | import WangsAlgorithm.Proposition 5 | import WangsAlgorithm.Prover 6 | 7 | import Data.List (intersperse) 8 | import Data.Maybe 9 | import Text.LaTeX 10 | import Text.LaTeX.Base.Class 11 | import Text.LaTeX.Base.Syntax 12 | import Text.LaTeX.Base.Pretty 13 | import Text.LaTeX.Packages.AMSMath 14 | 15 | ruleName :: Rule -> LaTeX 16 | ruleName r = math $ case r of 17 | Id -> "I" 18 | WeakeningLeft -> "WL" 19 | WeakeningRight -> "WR" 20 | NotLeft -> comm0 "lnot" <> "L" 21 | NotRight -> comm0 "lnot" <> "R" 22 | AndLeft -> comm0 "wedge" <> "L" 23 | AndRight -> comm0 "wedge" <> "R" 24 | OrLeft -> comm0 "vee" <> "L" 25 | OrRight -> comm0 "vee" <> "R" 26 | ImpliesLeft -> comm0 "supset" <> "L" 27 | ImpliesRight -> comm0 "supset" <> "R" 28 | 29 | prop :: Proposition -> LaTeX 30 | prop (Atom x) = fromString x 31 | prop (Not x) = comm0 "lnot" <> autoParens (prop x) 32 | prop (And x y) = autoParens (prop x `wedge` prop y) 33 | prop (Or x y) = autoParens (prop x `vee` prop y) 34 | prop (Implies x y) = autoParens (prop x `supset` prop y) 35 | 36 | sequent :: Sequent -> LaTeX 37 | sequent (Sequent x y) = 38 | math $ mconcat $ intersperse "," (map prop x) ++ [comm0 "vdash"] 39 | ++ intersperse "," (map prop y) 40 | 41 | proof :: Proof -> LaTeX 42 | proof (Linear (ProofStep r bf) n) = 43 | (if isNothing n then comm1 "AxiomC" mempty else mempty) <> 44 | maybe mempty proof n <> 45 | comm1 "RightLabel" (comm0 "scriptsize" <> ruleName r) <> 46 | comm1 "UnaryInfC" (sequent bf) 47 | proof (Branch (ProofStep r bf) p1 p2) = 48 | maybe mempty proof p1 <> 49 | maybe mempty proof p2 <> 50 | comm1 "RightLabel" (comm0 "scriptsize" <> ruleName r) <> 51 | comm1 "BinaryInfC" (sequent bf) 52 | 53 | entireProof :: Proof -> LaTeX 54 | entireProof = TeXEnv "prooftree" [] . proof 55 | 56 | latexProof :: Proof -> String 57 | latexProof = prettyLaTeX . entireProof 58 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.21 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /tests/tests.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module Main where 3 | 4 | import WangsAlgorithm.Parser 5 | import WangsAlgorithm.Proposition 6 | import WangsAlgorithm.Prover 7 | 8 | import Data.Maybe (isJust) 9 | import Control.Monad 10 | import Control.Applicative 11 | 12 | import Test.HUnit 13 | import Test.QuickCheck 14 | 15 | maybeReadSequent :: String -> Maybe Sequent 16 | maybeReadSequent s = case readSequent s of 17 | Left _ -> Nothing 18 | Right x -> Just x 19 | 20 | example :: Sequent 21 | example = Sequent [ Or (Atom "a") (Atom "b"), And (Atom "a") (Atom "c"), 22 | Not (Atom "b"), Implies (Atom "c") (Atom "d") ] 23 | [ Atom "b", Atom "c", And (Atom "c") (Atom "d") ] 24 | 25 | -- | These examples should all have a complete proof. 26 | tautologyExamples :: [(String, String)] 27 | tautologyExamples = 28 | [ ("Modus Ponens" , "[(p->q)&p] |- [q]") 29 | , ("Modus Tollens" , "[(p->q)&(~q)] |- [~p]") 30 | , ("Hypothetical Syllogism" , "[((p->q)&(q->r))] |- [p->r]") 31 | , ("Disjunctive Syllogism" , "[(p|q)&(~p)] |- [q]") 32 | , ("Constructive Dilemma" , "[(p->q)&(r->s)&(p|r)] |- [q|s]") 33 | , ("Destructive Dilemma" , "[(p->q)&(r->s)&((~q)|(~s))] |- [(~p)|(~r)]") 34 | , ("Bidirectional Dilemma" , "[(p->q)&(r->s)&(p|(~s))] |- [q|(~r)]") 35 | , ("Simplification" , "[p&q] |- [p]") 36 | , ("Conjunction" , "[p,q] |- [p&q]") 37 | , ("Addition" , "[p] |- [p|q]") 38 | , ("Composition" , "[(p->q)&(p->r)] |- [p->(q&r)]") 39 | , ("De Morgan's Theorem (1)" , "[~(p&q)] |- [(~p)|(~q)]") 40 | , ("De Morgan's Theorem (2)" , "[~(p|q)] |- [(~p)&(~q)]") 41 | , ("Commutation (1)" , "[p|q] |- [q|p]") 42 | , ("Commutation (2)" , "[p&q] |- [q&p]") 43 | , ("Association (1)" , "[p|(q|r)] |- [(p|q)|r]") 44 | , ("Association (2)" , "[p&(q&r)] |- [(p&q)&r]") 45 | , ("Distribution (1)" , "[p&(q|r)] |- [(p&q)|(p&r)]") 46 | , ("Distribution (2)" , "[p|(q&r)] |- [(p|q)&(p|r)]") 47 | , ("Double Negation" , "[p] |- [~(~p)]") 48 | , ("Transposition" , "[p->q] |- [(~q)->(~p)]") 49 | , ("Material Implication" , "[p->q] |- [(~p)|q]") 50 | , ("Exportation" , "[(p&q)->r] |- [p->(q->r)]") 51 | , ("Importation" , "[p->(q->r)] |- [(p&q)->r]") 52 | , ("Tautology (1)" , "[p] |- [p|p]") 53 | , ("Tautology (2)" , "[p] |- [p&p]") 54 | , ("Law of Excluded Middle" , "[] |- [p|(~p)]") 55 | , ("Law of Non-Contradiction", "[] |- [~(p&(~p))]") 56 | ] 57 | 58 | -- | These examples should not have a complete proof. 59 | unprovableExamples :: [String] 60 | unprovableExamples = 61 | -- Contradictions 62 | [ "[~p] |- [p]" 63 | , "[(~p)&(~q)] |- [p,q]" 64 | , "[p|q] |- [(~p)&(~q)]" 65 | -- Contingencies 66 | -- Conditional ones (not tautologies, so no complete proof) 67 | , "[~p, p&q] |- [q]" 68 | , "[(p&q)->r] |- [((p&q)->r)&(((~p)|(~q))->(~r))]" 69 | ] 70 | 71 | -- HUnit tests 72 | completeProofTests :: [Assertion] 73 | completeProofTests = 74 | map (\(s,t) -> assertEqual s (Just True) 75 | (completeProof <$> (prove =<< maybeReadSequent t))) 76 | tautologyExamples 77 | ++ map (\t -> assertEqual t (Just True) 78 | ((not . completeProof) <$> (prove =<< maybeReadSequent t))) 79 | unprovableExamples 80 | 81 | assertExample :: String -> Assertion 82 | assertExample s = assertEqual s (Just example) (maybeReadSequent s) 83 | 84 | tests :: Test 85 | tests = TestList $ map TestCase $ 86 | [ 87 | -- Simple parser tests 88 | 89 | -- empty list 90 | assertEqual "[] |- []" (Just $ Sequent [] []) (maybeReadSequent "[] |- []") 91 | -- singleton 92 | , assertEqual "[a] |- [a]" 93 | (Just $ Sequent [Atom "a"] [Atom "a"]) 94 | (maybeReadSequent "[a] |- [a]") 95 | -- multiple atomic 96 | , assertEqual "[a,b] |- [a,c]" 97 | (Just $ Sequent [Atom "a", Atom "b"] [Atom "a", Atom "c"]) 98 | (maybeReadSequent "[a,b] |- [a,c]") 99 | -- multiple connectives 100 | , assertExample "[a|b, a&c, ~b, c->d] |- [b, c, c&d]" 101 | -- with spaces 102 | , assertExample "[a | b, a & c, ~b, c -> d] |- [b, c, c & d]" 103 | -- fancy characters 104 | , assertExample "[(a)∨(b),(a)∧(c),¬(b),(c)⊃(d)]⊢[b,c,(c)∧(d)]" 105 | -- fancy characters with spaces 106 | , assertExample "[(a) ∨ (b),(a) ∧ (c),¬(b),(c) ⊃ (d)] ⊢ [b,c,(c) ∧ (d)]" 107 | ] ++ completeProofTests 108 | 109 | -- QuickCheck tests 110 | 111 | instance Arbitrary Proposition where 112 | -- Forcing one arbitrary per connective to have smaller 113 | -- propositions that are easier to test. 114 | arbitrary = oneof [ liftM Atom (elements $ map (:[]) ['a'..'z']) 115 | , liftM Not arbitrary 116 | , liftM2 And arbitrary (return (Atom "x")) 117 | , liftM2 Or arbitrary (return (Atom "x")) 118 | , liftM2 Implies arbitrary (return (Atom "x")) 119 | , liftM2 And (return (Atom "y")) arbitrary 120 | , liftM2 Or (return (Atom "y")) arbitrary 121 | , liftM2 Implies (return (Atom "y")) arbitrary ] 122 | 123 | instance Arbitrary Sequent where 124 | arbitrary = liftM2 Sequent arbitrary arbitrary 125 | 126 | -- | It should be able to parse back the string representation of a sequent. 127 | parseable :: Sequent -> Bool 128 | parseable = isJust . maybeReadSequent . show 129 | 130 | -- TODO: more QuickCheck tests, I couldn't think of any other properties. 131 | 132 | -- General 133 | 134 | runTests :: IO () 135 | runTests = do 136 | _ <- runTestTT tests 137 | mapM_ quickCheck [parseable] 138 | return () 139 | 140 | -- | For now, main will run our tests. 141 | main :: IO () 142 | main = runTests 143 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | WangsAlgorithm [![Build Status](https://secure.travis-ci.org/joom/WangsAlgorithm.svg)](http://travis-ci.org/joom/WangsAlgorithm) 2 | ============== 3 | 4 | A propositional theorem prover in Haskell, using [Wang's Algorithm](http://www.cs.bham.ac.uk/research/projects/poplog/doc/popteach/wang), based on the sequent calculus (LK). Reading [a Prolog implementation](https://github.com/benhuds/Prolog) helped me understand it better. 5 | 6 | ## Usage 7 | 8 | In order to use or compile the program you need to have [Stack](http://haskellstack.org) installed. 9 | 10 | After you cloning the repository, go to the repository folder and do 11 | 12 | ```bash 13 | stack install 14 | ``` 15 | 16 | Now you installed the program. You can run it like this: 17 | 18 | ```bash 19 | wang --sequent "[(p->q)&(p->r)] |- [p->(q&r)]" --backend Text 20 | ``` 21 | 22 | Or shortly: 23 | 24 | ```bash 25 | wang -s "[(p->q)&(p->r)] |- [p->(q&r)]" -b Text 26 | ``` 27 | 28 | You can also use `LaTeX` for an output. 29 | 30 | Here's an example text proof for that: 31 | 32 | ``` 33 | Before: [((p) ⊃ (q)) ∧ ((p) ⊃ (r))] ⊢ [(p) ⊃ ((q) ∧ (r))] 34 | Rule: AndLeft 35 | ------------------- 36 | Before: [(p) ⊃ (q),(p) ⊃ (r)] ⊢ [(p) ⊃ ((q) ∧ (r))] 37 | Rule: ImpliesRight 38 | ------------------- 39 | Before: [(p) ⊃ (q),(p) ⊃ (r),p] ⊢ [(q) ∧ (r)] 40 | Rule: AndRight 41 | ------------------- 42 | First branch: 43 | Before: [(p) ⊃ (q),(p) ⊃ (r),p] ⊢ [q] 44 | Rule: ImpliesLeft 45 | ------------------- 46 | First branch: 47 | Before: [(p) ⊃ (r),p] ⊢ [p,q] 48 | Rule: WeakeningLeft 49 | ------------------- 50 | Before: [p] ⊢ [p,q] 51 | Rule: WeakeningRight 52 | ------------------- 53 | Before: [p] ⊢ [p] 54 | Rule: Id 55 | ------------------- 56 | End. 57 | 58 | ------------------- 59 | Second branch: 60 | Before: [q,(p) ⊃ (r),p] ⊢ [q] 61 | Rule: WeakeningLeft 62 | ------------------- 63 | Before: [q,p] ⊢ [q] 64 | Rule: WeakeningLeft 65 | ------------------- 66 | Before: [q] ⊢ [q] 67 | Rule: Id 68 | ------------------- 69 | End. 70 | 71 | ------------------- 72 | 73 | ------------------- 74 | Second branch: 75 | Before: [(p) ⊃ (q),(p) ⊃ (r),p] ⊢ [r] 76 | Rule: ImpliesLeft 77 | ------------------- 78 | First branch: 79 | Before: [(p) ⊃ (r),p] ⊢ [p,r] 80 | Rule: WeakeningLeft 81 | ------------------- 82 | Before: [p] ⊢ [p,r] 83 | Rule: WeakeningRight 84 | ------------------- 85 | Before: [p] ⊢ [p] 86 | Rule: Id 87 | ------------------- 88 | End. 89 | 90 | ------------------- 91 | Second branch: 92 | Before: [q,(p) ⊃ (r),p] ⊢ [r] 93 | Rule: ImpliesLeft 94 | ------------------- 95 | First branch: 96 | Before: [q,p] ⊢ [p,r] 97 | Rule: WeakeningLeft 98 | ------------------- 99 | Before: [p] ⊢ [p,r] 100 | Rule: WeakeningRight 101 | ------------------- 102 | Before: [p] ⊢ [p] 103 | Rule: Id 104 | ------------------- 105 | End. 106 | 107 | ------------------- 108 | Second branch: 109 | Before: [r,q,p] ⊢ [r] 110 | Rule: WeakeningLeft 111 | ------------------- 112 | Before: [r,p] ⊢ [r] 113 | Rule: WeakeningLeft 114 | ------------------- 115 | Before: [r] ⊢ [r] 116 | Rule: Id 117 | ------------------- 118 | End. 119 | 120 | ------------------- 121 | 122 | ------------------- 123 | 124 | ------------------- 125 | Proof completed. 126 | ``` 127 | 128 | Here's the LaTeX output for the same sequent. 129 | 130 | ``` 131 | \begin{prooftree} 132 | \AxiomC{} \RightLabel{\scriptsize $I$} 133 | \UnaryInfC{$p\vdash p$} \RightLabel{\scriptsize $WR$} 134 | \UnaryInfC{$p\vdash p,q$} \RightLabel{\scriptsize $WL$} 135 | \UnaryInfC{$\left( p\supset r\right) ,p\vdash p,q$} 136 | \AxiomC{} \RightLabel{\scriptsize $I$} 137 | \UnaryInfC{$q\vdash q$} \RightLabel{\scriptsize $WL$} 138 | \UnaryInfC{$q,p\vdash q$} \RightLabel{\scriptsize $WL$} 139 | \UnaryInfC{$q,\left( p\supset r\right) ,p\vdash q$} 140 | \RightLabel{\scriptsize $\supset L$} 141 | \BinaryInfC{$\left( p\supset q\right) ,\left( p\supset 142 | r\right) ,p\vdash q$} \AxiomC{} 143 | \RightLabel{\scriptsize $I$} \UnaryInfC{$p\vdash p$} 144 | \RightLabel{\scriptsize $WR$} \UnaryInfC{$p\vdash p,r$} 145 | \RightLabel{\scriptsize $WL$} 146 | \UnaryInfC{$\left( p\supset r\right) ,p\vdash p,r$} 147 | \AxiomC{} \RightLabel{\scriptsize $I$} 148 | \UnaryInfC{$p\vdash p$} \RightLabel{\scriptsize $WR$} 149 | \UnaryInfC{$p\vdash p,r$} \RightLabel{\scriptsize $WL$} 150 | \UnaryInfC{$q,p\vdash p,r$} \AxiomC{} 151 | \RightLabel{\scriptsize $I$} \UnaryInfC{$r\vdash r$} 152 | \RightLabel{\scriptsize $WL$} \UnaryInfC{$r,p\vdash r$} 153 | \RightLabel{\scriptsize $WL$} 154 | \UnaryInfC{$r,q,p\vdash r$} 155 | \RightLabel{\scriptsize $\supset L$} 156 | \BinaryInfC{$q,\left( p\supset r\right) ,p\vdash r$} 157 | \RightLabel{\scriptsize $\supset L$} 158 | \BinaryInfC{$\left( p\supset q\right) ,\left( p\supset 159 | r\right) ,p\vdash r$} 160 | \RightLabel{\scriptsize $\wedge R$} 161 | \BinaryInfC{$\left( p\supset q\right) ,\left( p\supset 162 | r\right) ,p\vdash \left( q\wedge r\right) $} 163 | \RightLabel{\scriptsize $\supset R$} 164 | \UnaryInfC{$\left( p\supset q\right) ,\left( p\supset 165 | r\right) \vdash \left( p\supset \left( q\wedge 166 | r\right) \right) $} 167 | \RightLabel{\scriptsize $\wedge L$} 168 | \UnaryInfC{$\left( \left( p\supset q\right) \wedge 169 | \left( p\supset r\right) \right) \vdash \left( 170 | p\supset \left( q\wedge r\right) \right) $} 171 | \end{prooftree} 172 | ``` 173 | 174 | If you want to run the tests, use this command: 175 | 176 | ```bash 177 | stack test 178 | ``` 179 | 180 | # Further Reading 181 | 182 | * Hao Wang, 1960, "Toward Mechanical Mathematics" 183 | * John McCarthy, 1961, "LISP 1.5 Programmer's Manual" 184 | 185 | ## License 186 | 187 | The MIT License (MIT) 188 | 189 | Copyright (c) 2014 Joomy Korkut 190 | -------------------------------------------------------------------------------- /src/WangsAlgorithm/Prover.hs: -------------------------------------------------------------------------------- 1 | module WangsAlgorithm.Prover where 2 | 3 | import Data.List (partition, intersect, delete, (\\)) 4 | import WangsAlgorithm.Proposition 5 | 6 | data Rule = Id 7 | | WeakeningLeft 8 | | WeakeningRight 9 | | NotLeft 10 | | NotRight 11 | | AndLeft 12 | | AndRight 13 | | OrLeft 14 | | OrRight 15 | | ImpliesLeft 16 | | ImpliesRight 17 | deriving (Show, Eq) 18 | 19 | data ProofStep = ProofStep { rule :: Rule 20 | , before :: Sequent 21 | } deriving (Show, Eq) 22 | 23 | data Proof = Linear { step :: ProofStep 24 | , next :: Maybe Proof } 25 | | Branch { step :: ProofStep 26 | , first :: Maybe Proof 27 | , second :: Maybe Proof 28 | } deriving Eq 29 | 30 | -- | Returns the taken proof steps. 31 | -- It doesn't have to be a complete proof. 32 | -- Even if it doesn't succeed to finish the proof, 33 | -- it is going to return the proof steps taken. 34 | prove :: Sequent -> Maybe Proof 35 | prove sequent@(Sequent lefts rights) 36 | | lefts == rights = 37 | Just $ Linear (ProofStep Id sequent) Nothing 38 | 39 | -- Weakening rules 40 | | all (not . null) [lefts \\ rights, intersection] = 41 | let (x:_) = lefts \\ rights in 42 | let new = delete x lefts `proves` rights in 43 | Just $ Linear (ProofStep WeakeningLeft sequent) (prove new) 44 | | all (not . null) [rights \\ lefts, intersection] = 45 | let (x:_) = rights \\ lefts in 46 | let new = lefts `proves` delete x rights in 47 | Just $ Linear (ProofStep WeakeningRight sequent) (prove new) 48 | 49 | -- If one of the formulae separated by commas is the negation of a 50 | -- formula, drop the negation sign and move it to the other side of the 51 | -- arrow. 52 | | any isNot lefts = 53 | let new = leftsWithoutNot `proves` (rights ++ map notProp leftsWithNot) 54 | in Just $ Linear (ProofStep NotLeft sequent) (prove new) 55 | | any isNot rights = 56 | let new = (lefts ++ map notProp rightsWithNot) `proves` rightsWithoutNot 57 | in Just $ Linear (ProofStep NotRight sequent) (prove new) 58 | 59 | -- If the principal connective of a formula on the left is ^ (and), or on 60 | -- the right of the arrow is v (or), replace the connective by a comma. 61 | | any isAnd lefts = 62 | let new = (leftsWithoutAnd ++ concatMap (toList . andProp) leftsWithAnd) 63 | `proves` rights 64 | in Just $ Linear (ProofStep AndLeft sequent) (prove new) 65 | | any isOr rights = 66 | let new = lefts `proves` 67 | (rightsWithoutOr ++ concatMap (toList . orProp) rightsWithOr) 68 | in Just $ Linear (ProofStep OrRight sequent) (prove new) 69 | | any isImp rights = 70 | let new = (lefts ++ map (fst . impProp) rightsWithImp) `proves` 71 | (rightsWithoutImp ++ map (snd . impProp) rightsWithImp) 72 | in Just $ Linear (ProofStep ImpliesRight sequent) (prove new) 73 | 74 | -- If the principal connective of a formula on the left is v (or), or on 75 | -- the right of the arrow is ^ (and), then produce two new lines, each 76 | -- with one of the two sub-formulae replacing the formula. Both of these 77 | -- must be proved in order to prove the original theorem. 78 | | any isOr lefts = 79 | let (x:_) = leftsWithOr in 80 | let (p1, p2) = orProp x in 81 | let new1 = (p1 : filter (/= x) lefts) `proves` rights in 82 | let new2 = (p2 : filter (/= x) lefts) `proves` rights in 83 | Just $ Branch (ProofStep OrLeft sequent) 84 | (prove new1) (prove new2) 85 | | any isAnd rights = 86 | let (x:_) = rightsWithAnd in 87 | let (p1, p2) = andProp x in 88 | let new1 = lefts `proves` (p1 : filter (/= x) rights) in 89 | let new2 = lefts `proves` (p2 : filter (/= x) rights) in 90 | Just $ Branch (ProofStep AndRight sequent) 91 | (prove new1) (prove new2) 92 | | any isImp lefts = 93 | let (x:_) = leftsWithImp in 94 | let (p1, p2) = impProp x in 95 | let new1 = filter (/= x) lefts `proves` (p1 : rights) in 96 | let new2 = (p2 : filter (/= x) lefts) `proves` rights in 97 | Just $ Branch (ProofStep ImpliesLeft sequent) 98 | (prove new1) (prove new2) 99 | 100 | | otherwise = Nothing 101 | where (leftsWithNot, leftsWithoutNot) = partition isNot lefts 102 | (leftsWithAnd, leftsWithoutAnd) = partition isAnd lefts 103 | (leftsWithOr, _) = partition isOr lefts 104 | (leftsWithImp, _) = partition isImp lefts 105 | (rightsWithNot, rightsWithoutNot) = partition isNot rights 106 | (rightsWithAnd, _) = partition isAnd rights 107 | (rightsWithOr, rightsWithoutOr) = partition isOr rights 108 | (rightsWithImp, rightsWithoutImp) = partition isImp rights 109 | toList (x, y) = [x, y] 110 | intersection = lefts `intersect` rights 111 | 112 | -- | Adds 4 spaces in front of every line in the string. 113 | tab :: String -> String 114 | tab = unlines . map (" "++) . lines 115 | 116 | instance Show Proof where 117 | show (Linear (ProofStep r bf) n) = init $ unlines [ 118 | "Before: " ++ show bf, 119 | "Rule: " ++ show r, 120 | "-------------------", 121 | rest ] 122 | where rest = case n of 123 | Just proof -> show proof 124 | _ -> "End." 125 | show (Branch (ProofStep r bf) p1 p2) = init $ unlines [ 126 | "Before: " ++ show bf, 127 | "Rule: " ++ show r, 128 | "-------------------", 129 | "First branch: ", 130 | tab (rest p1), 131 | "-------------------", 132 | "Second branch: ", 133 | tab (rest p2), 134 | "-------------------" ] 135 | where rest p = case p of 136 | Just proof -> show proof 137 | _ -> "End." 138 | 139 | -- | Returns True if all branches end with Id. 140 | completeProof :: Proof -> Bool 141 | completeProof (Linear (ProofStep r _) n) = r == Id || rest 142 | where rest = case n of 143 | Just x -> completeProof x 144 | _ -> False 145 | completeProof (Branch (ProofStep _ _) p1 p2) = rest p1 && rest p2 146 | where rest p = case p of 147 | Just x -> completeProof x 148 | _ -> False 149 | 150 | showProof :: Proof -> String 151 | showProof pf = show pf ++ "\n" ++ 152 | if completeProof pf 153 | then "Proof completed." 154 | else "This cannot be proved." 155 | --------------------------------------------------------------------------------