├── Logic.hs ├── Main.hs ├── README.md └── Util.hs /Logic.hs: -------------------------------------------------------------------------------- 1 | module Logic where 2 | 3 | data Expr = Nil | NM String | Not Expr | And Expr Expr | Or Expr Expr | If Expr Expr | Iff Expr Expr | A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z 4 | deriving (Show, Eq) 5 | 6 | type Rule = Expr -> Maybe Expr 7 | type DoubleRule = Expr -> Expr -> Maybe Expr 8 | 9 | type Line = (Expr, (String, [Expr])) 10 | 11 | -- Double Negation Elimination 12 | dne :: Rule 13 | dne (Not (Not p)) = Just p 14 | dne _ = Nothing 15 | 16 | -- Double Negation Introduction 17 | dni :: Rule 18 | dni = Just . Not . Not 19 | 20 | -- Left And Elimination 21 | ael :: Rule 22 | ael (And p q) = Just p 23 | ael _ = Nothing 24 | 25 | -- Right And Elimination 26 | aer :: Rule 27 | aer (And p q) = Just q 28 | aer _ = Nothing 29 | 30 | -- Left If and Only If Elimination 31 | iffel :: Rule 32 | iffel (Iff p q) = Just (If p q) 33 | iffel _ = Nothing 34 | 35 | -- Right If and Only If Elimination 36 | iffer :: Rule 37 | iffer (Iff p q) = Just (If q p) 38 | iffer _ = Nothing 39 | 40 | -- Modus Ponendo Ponens 41 | mpp :: DoubleRule 42 | mpp (If p q) r = if p == r then Just q else Nothing 43 | mpp _ _ = Nothing 44 | 45 | -- And Introduction 46 | ai :: DoubleRule 47 | ai p q = Just (And p q) 48 | 49 | -- Modus Tonendo Tollens 50 | mtt :: DoubleRule 51 | mtt (If p q) (Not r) = if q == r then Just (Not p) else Nothing 52 | mtt _ _ = Nothing 53 | 54 | -- Left Disjunctive Syllogism 55 | dsl :: DoubleRule 56 | dsl (Or p q) (Not r) = if p == r then Just q else Nothing 57 | dsl _ _ = Nothing 58 | 59 | -- Right Disjunctive Syllogism 60 | dsr :: DoubleRule 61 | dsr (Or p q) (Not r) = if q == r then Just p else Nothing 62 | dsr _ _ = Nothing 63 | 64 | -- OR introduction 65 | ori :: DoubleRule 66 | ori p q = Just (Or p q) 67 | 68 | rulePairs :: [(Rule, String)] 69 | rulePairs = [(dne, "DNE"), (dni, "DNI"), (ael, "∧E"), (aer, "∧E"), (iffel, "↔E"), (iffer, "↔E")] 70 | 71 | doubleRulePairs :: [(DoubleRule, String)] 72 | doubleRulePairs = [(mpp, "MPP"), (ai, "∧I"), (mtt, "MTT"), (dsl, "DS"), (dsr, "DS")] -- , (ori, "∨I")] 73 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import Data.List 3 | 4 | import Logic 5 | import Util 6 | 7 | applySingle :: [(Expr, t)] -> [Line] 8 | applySingle props = catMaybeFst [((r p), (n, [p])) | pp <- props, rp <- rulePairs, 9 | let (r, n) = rp, 10 | let (p, o) = pp] 11 | 12 | applyDouble :: [(Expr, t)] -> [Line] 13 | applyDouble props = catMaybeFst [(r p q, (n, [p,q])) | pp <- props, qp <- props, rp <- doubleRulePairs, 14 | let (r, n) = rp, 15 | let (p, o) = pp, 16 | let (q, s) = qp] 17 | 18 | apply :: [Line] -> [Line] 19 | apply props = props ++ applySingle props ++ applyDouble props 20 | 21 | resolve :: [Line] -> [[Line]] 22 | resolve = unfoldr (Just . join (,) . apply) 23 | 24 | isValid :: [Expr] -> Expr -> Bool 25 | isValid ps c = elem c . map fst . concat . resolve . addSups $ ps 26 | 27 | -- prove :: [Expr] -> Expr -> [(Expr, [Char])] 28 | prove :: [Expr] -> Expr -> [(Expr, (String, [Expr]))] 29 | prove ps conc = nub $ go [conc] [] 30 | where go seeds res = if length (intersect seeds ps) == length seeds 31 | then (addSups ps) ++ res 32 | else go (concatMap prev lines) (lines ++ res) 33 | where lines = map findLine seeds 34 | findLine p = val . find (\b -> (prem b) == p) . concat $ rose 35 | where rose = takeWhileInclusive findConclusion (resolve (addSups ps)) 36 | where findConclusion b = all (not . (\a -> (prem a) == conc)) b 37 | 38 | main :: IO () 39 | main = prettyProof . addNumbers $ prove 40 | 41 | [ (If R (Not P)), 42 | (Or Q P), 43 | (Or R (Not (Or Q P))) 44 | ] (Q) 45 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # :computer: Propositional Derivation Machine 2 | 3 | I wrote this library to do my Philosophy 201 (Introductory Logic) homework for me. 4 | 5 | For a good description of propositional logic, see this page: https://en.wikipedia.org/wiki/Propositional_calculus 6 | 7 | What we want is to give the program a book problem, and for the derivation machine to prove that it is true. The program lazily builds an infinite tree of logical sentences which "follow" from the given premises. Once it generates something that remembles the conclusion it walks backwards to the root and prints the result. 8 | 9 | --- 10 | 11 | A simple book problem in Haskell syntax (a list of premises and a conclusion): 12 | 13 | ``` 14 | [ (If A B), 15 | (Not B) 16 | ] (Not A) 17 | ``` 18 | 19 | This conclusion follows from the premises by the simple but unintuaitive rule called "modus tollendo tollens." Haskell gives us the answer: 20 | 21 | ``` 22 | 1 "If A B" S 23 | 2 "Not B" S 24 | 3 "Not A" 1,2 MTT 25 | (0.03 secs, 149,584 bytes) 26 | ``` 27 | 28 | Although this is an elementary example, the derivation machine can do all propositional derivations that involve the *simple rules*. And now we have no more homework for first term! 29 | 30 | --- 31 | 32 | Disclaimer: do your homework. 33 | 34 | --- 35 | 36 | ~~Will it be slow?~~ 37 | 38 | It's fast as hell! 39 | -------------------------------------------------------------------------------- /Util.hs: -------------------------------------------------------------------------------- 1 | module Util where 2 | 3 | import Data.List 4 | import Text.PrettyPrint.Boxes 5 | 6 | takeWhileInclusive :: (a -> Bool) -> [a] -> [a] 7 | takeWhileInclusive _ [] = [] 8 | takeWhileInclusive p (x:xs) = x : if p x then takeWhileInclusive p xs 9 | else [] 10 | 11 | catMaybeFst :: [(Maybe t, t1)] -> [(t, t1)] 12 | catMaybeFst ls = [(x, y) | (Just x, y) <- ls] 13 | 14 | prem :: (t, (t1, t2)) -> t 15 | prem (a, (b, c)) = a 16 | 17 | name :: (t, (t1, t2)) -> t1 18 | name (a, (b, c)) = b 19 | 20 | prev :: (t, (t1, t2)) -> t2 21 | prev (a, (b, c)) = c 22 | 23 | val :: Maybe t -> t 24 | val (Just a) = a 25 | 26 | addSups :: [t] -> [(t, ([Char], [t]))] 27 | addSups = map (\p -> (p, ("S", [p]))) 28 | 29 | addNumbers proof = zip [1..] (map (\(a,(b,c)) -> (a,(b, map (\x -> val (findIndex (\y -> y == x) numbers) + 1) c))) proof) 30 | where numbers = map fst proof 31 | 32 | prettyProof xs = printBox $ hsep 2 left (map (vcat left . map text) (transpose [[show a, show b, (if c /= "S" then (intercalate "," (map show d)) ++ " " else "") ++ c] | (a,(b,(c,d))) <- xs])) 33 | --------------------------------------------------------------------------------