import SimpleProp data Discrim a = Alpha a a | Beta a a | Lit a deriving (Show) discrim :: Prop a -> Discrim (Prop a) discrim TruthP = Lit TruthP discrim AbsurdP = Lit AbsurdP discrim (LetterP s) = Lit (LetterP s) discrim (AndP x y) = Alpha x y discrim (OrP x y) = Beta x y discrim (ImpliesP x y) = Beta (NotP x) y discrim (NotP (OrP x y)) = Alpha (NotP x) (NotP y) discrim (NotP (ImpliesP x y)) = Alpha x (NotP y) discrim (NotP (AndP x y)) = Beta (NotP x) (NotP y) discrim (NotP (NotP x)) = discrim x discrim (NotP TruthP) = Lit AbsurdP discrim (NotP AbsurdP) = Lit TruthP discrim (NotP (LetterP s)) = Lit (NotP (LetterP s)) processCl :: [Prop a] -> [[Prop a]] processCl [] = [[]] processCl (p : ps) = case (discrim p) of Lit x -> map (x:) (processCl ps) Alpha x y -> processCl (x : ps) ++ processCl (y : ps) Beta x y -> processCl (x : y : ps) processCl' :: Eq a => [Prop a] -> [[Prop a]] processCl' [] = [[]] processCl' (p : ps) = case (discrim p) of Lit x -> consif x (processCl' ps) Alpha x y -> processCl' (x : ps) ++ processCl' (y : ps) Beta x y -> processCl' (x : y : ps) consif :: Eq a => Prop a -> [[Prop a]] -> [[Prop a]] consif x [] = [] --consif x ((AbsurdP:lls):ls) = (AbsurdP:lls):(consif x ls) consif x (l:ls) = if AbsurdP `elem` l then l:(consif x ls) else if f' x l then (AbsurdP:l):(consif x ls) else (x:l):(consif x ls) --tableau :: Prop a -> Bool tableau prop = all id (map f (processCl [prop])) tableau' prop = all (elem AbsurdP) (processCl' [prop]) -- quick and dirty contradiction checking functions: f (p:[]) = False f (p:ps) = case p of NotP (LetterP v) -> LetterP v `elem` ps || f ps LetterP v -> NotP (LetterP v) `elem` ps || f ps f' x (p:[]) = False f' x (ps) = case x of NotP (LetterP v) -> LetterP v `elem` ps LetterP v -> NotP (LetterP v) `elem` ps lp = LetterP 'p' lq = LetterP 'q' lr = LetterP 'r' -- works (and should): e0 = lq ~> (lp ~> lq) e1 = lp \/ (lq /\ lr) ~> (lp \/ lq) /\ (lp \/ lr) e2 = (lp ~> (lq ~> lr)) ~> ((lp ~> lq) ~> (lp ~> lr)) e4 = (lq /\ (NotP lq)) ~> lq e5 = NotP (lp /\ lq) ~> (NotP (lp) \/ NotP (lq)) e9 = foldl (/\) e0 (take 20000 (cycle [e1, e2, e4, e5])) -- doesn't work (and shouldn't): ee = lq ~> (lp ~> lr) e3 = (lq \/ (NotP lq)) ~> lq main = print (tableau' e9) -- pasted below: quick profiling numbers of tableau vs tableau' Mon Oct 13 13:10 2014 Time and Allocation Profiling Report (Final) ex3 +RTS -p -RTS total time = 18.83 secs (18834 ticks @ 1000 us, 1 processor) total alloc = 36,480,972,272 bytes (excludes profiling overheads) COST CENTRE MODULE %time %alloc processCl Main 99.6 99.9 individual inherited COST CENTRE MODULE no. entries %time %alloc %time %alloc MAIN MAIN 45 0 0.0 0.0 100.0 100.0 CAF Main 88 0 0.0 0.0 100.0 100.0 e5 Main 112 1 0.0 0.0 0.0 0.0 \/ SimpleProp 115 1 0.0 0.0 0.0 0.0 /\ SimpleProp 114 1 0.0 0.0 0.0 0.0 ~> SimpleProp 113 1 0.0 0.0 0.0 0.0 e4 Main 109 1 0.0 0.0 0.0 0.0 /\ SimpleProp 111 1 0.0 0.0 0.0 0.0 ~> SimpleProp 110 1 0.0 0.0 0.0 0.0 e2 Main 107 1 0.0 0.0 0.0 0.0 ~> SimpleProp 108 6 0.0 0.0 0.0 0.0 lr Main 106 1 0.0 0.0 0.0 0.0 e1 Main 102 1 0.0 0.0 0.0 0.0 /\ SimpleProp 105 2 0.0 0.0 0.0 0.0 \/ SimpleProp 104 3 0.0 0.0 0.0 0.0 ~> SimpleProp 103 1 0.0 0.0 0.0 0.0 lp Main 99 1 0.0 0.0 0.0 0.0 lq Main 98 1 0.0 0.0 0.0 0.0 e0 Main 96 1 0.0 0.0 0.0 0.0 ~> SimpleProp 97 2 0.0 0.0 0.0 0.0 e9 Main 94 1 0.0 0.0 0.0 0.0 /\ SimpleProp 95 20000 0.0 0.0 0.0 0.0 main Main 90 1 0.0 0.0 100.0 100.0 tableau Main 91 1 0.1 0.0 100.0 100.0 f Main 100 75001 0.1 0.0 0.2 0.0 == SimpleProp 101 190002 0.1 0.0 0.1 0.0 processCl Main 92 440006 99.6 99.9 99.8 100.0 discrim Main 93 385005 0.1 0.0 0.1 0.0 CAF GHC.IO.Handle.FD 81 0 0.0 0.0 0.0 0.0 CAF GHC.Show 78 0 0.0 0.0 0.0 0.0 CAF GHC.Conc.Signal 77 0 0.0 0.0 0.0 0.0 CAF GHC.IO.Encoding 75 0 0.0 0.0 0.0 0.0 CAF GHC.IO.Encoding.Iconv 65 0 0.0 0.0 0.0 0.0 Mon Oct 13 13:12 2014 Time and Allocation Profiling Report (Final) ex3 +RTS -p -RTS total time = 19.38 secs (19378 ticks @ 1000 us, 1 processor) total alloc = 36,527,252,640 bytes (excludes profiling overheads) COST CENTRE MODULE %time %alloc processCl' Main 99.1 99.8 individual inherited COST CENTRE MODULE no. entries %time %alloc %time %alloc MAIN MAIN 45 0 0.0 0.0 100.0 100.0 CAF Main 88 0 0.0 0.0 100.0 100.0 e5 Main 115 1 0.0 0.0 0.0 0.0 \/ SimpleProp 118 1 0.0 0.0 0.0 0.0 /\ SimpleProp 117 1 0.0 0.0 0.0 0.0 ~> SimpleProp 116 1 0.0 0.0 0.0 0.0 e4 Main 112 1 0.0 0.0 0.0 0.0 /\ SimpleProp 114 1 0.0 0.0 0.0 0.0 ~> SimpleProp 113 1 0.0 0.0 0.0 0.0 e2 Main 110 1 0.0 0.0 0.0 0.0 ~> SimpleProp 111 6 0.0 0.0 0.0 0.0 lr Main 109 1 0.0 0.0 0.0 0.0 e1 Main 105 1 0.0 0.0 0.0 0.0 /\ SimpleProp 108 2 0.0 0.0 0.0 0.0 \/ SimpleProp 107 3 0.0 0.0 0.0 0.0 ~> SimpleProp 106 1 0.0 0.0 0.0 0.0 lp Main 100 1 0.0 0.0 0.0 0.0 lq Main 98 1 0.0 0.0 0.0 0.0 e0 Main 96 1 0.0 0.0 0.0 0.0 ~> SimpleProp 97 2 0.0 0.0 0.0 0.0 e9 Main 94 1 0.0 0.0 0.0 0.0 /\ SimpleProp 95 20000 0.0 0.0 0.0 0.0 main Main 90 1 0.0 0.0 100.0 100.0 tableau' Main 91 1 0.1 0.0 100.0 100.0 == SimpleProp 104 65001 0.0 0.0 0.0 0.0 processCl' Main 92 440006 99.1 99.8 99.8 100.0 consif Main 99 440006 0.4 0.1 0.7 0.2 == SimpleProp 102 275003 0.0 0.0 0.0 0.0 f' Main 101 215003 0.1 0.0 0.2 0.0 == SimpleProp 103 185002 0.1 0.0 0.1 0.0 discrim Main 93 385005 0.1 0.0 0.1 0.0 CAF GHC.IO.Handle.FD 81 0 0.0 0.0 0.0 0.0 CAF GHC.Show 78 0 0.0 0.0 0.0 0.0 CAF GHC.Conc.Signal 77 0 0.0 0.0 0.0 0.0 CAF GHC.IO.Encoding 75 0 0.0 0.0 0.0 0.0 CAF GHC.IO.Encoding.Iconv 65 0 0.0 0.0 0.0 0.0