This commit is contained in:
ryuga4 2019-05-28 00:39:24 +02:00
parent 864880d58d
commit 98c0f85e6a
4 changed files with 21 additions and 20 deletions

View File

@ -3,4 +3,4 @@ module Main where
import Lib import Lib
main :: IO () main :: IO ()
main = go main = getLine >>= go

View File

@ -34,9 +34,13 @@ executables:
ghc-options: ghc-options:
- -threaded - -threaded
- -rtsopts - -rtsopts
- -static
- -O2
- -with-rtsopts=-N - -with-rtsopts=-N
dependencies: dependencies:
- parser-sandbox - parser-sandbox
cc-options: -static
ld-options: -static -pthread
tests: tests:
parser-sandbox-test: parser-sandbox-test:

BIN
parser-sandbox-exe Executable file

Binary file not shown.

View File

@ -17,6 +17,7 @@ import Text.Megaparsec
import Text.Megaparsec.Char import Text.Megaparsec.Char
import Data.Void import Data.Void
import Control.Monad.Combinators.Expr import Control.Monad.Combinators.Expr
import Data.List
type Parser = Parsec Void String type Parser = Parsec Void String
@ -36,25 +37,12 @@ data Sentence = T
| Sentence `SAND` Sentence | Sentence `SAND` Sentence
| Sentence `SEQ` Sentence | Sentence `SEQ` Sentence
| Sentence `SIMP` Sentence | Sentence `SIMP` Sentence
deriving (Eq) deriving (Eq, Show)
instance Show Sentence where
show T = "T"
show F = "F"
show (V c) = [c]
show (N s) = "~"++show s
show (SOR a b) = "(" ++ show a ++ " v " ++ show b ++ ")"
show (SAND a b) = "(" ++ show a ++ " ^ " ++ show b ++ ")"
show (SEQ a b) = "(" ++ show a ++ " == " ++ show b ++ ")"
show (SIMP a b) = "(" ++ show a ++ " => " ++ show b ++ ")"
sentence :: Parser Sentence sentence :: Parser Sentence
sentence = all <|> parens sentence sentence = all <|> parens sentence
where where
all = t <|> f <|> v <|> neg <|> try (parens $ makeExprParser sentence [[bin "v" SOR, bin "^" SAND] all = t <|> f <|> v <|> neg <|> or' <|> and' <|> eq' <|> imp'
,[bin "==" SEQ, bin "=>" SIMP]])
t = do t = do
reserved "T" reserved "T"
return T return T
@ -62,17 +50,25 @@ sentence = all <|> parens sentence
reserved "F" reserved "F"
return F return F
v = do v = do
i <- oneOf ['a'..'z'] i <- oneOf $ ['a'..'z'] \\ ['v']
space space
return $ V i return $ V i
bin name f = InfixL (f <$ (string name >> space)) bin a b = try $ parens $ do
s1 <- sentence
space
string a
space
s2 <- sentence
return $ b s1 s2
or' = bin "v" SOR
and' = bin "^" SAND
eq' = bin "==" SEQ
imp' = bin "=>" SIMP
neg = do neg = do
char '~' char '~'
s1 <- sentence s1 <- sentence
return $ N s1 return $ N s1
tautology :: Sentence -> StateT [(Char,Bool)] [] Bool tautology :: Sentence -> StateT [(Char,Bool)] [] Bool
tautology T = return True tautology T = return True
tautology F = return False tautology F = return False
@ -90,6 +86,7 @@ tautology (SOR a b) = liftM2 (||) (tautology a) (tautology b)
tautology (SAND a b) = liftM2 (&&) (tautology a) (tautology b) tautology (SAND a b) = liftM2 (&&) (tautology a) (tautology b)
tautology (SEQ a b) = liftM2 (==) (tautology a) (tautology b) tautology (SEQ a b) = liftM2 (==) (tautology a) (tautology b)
tautology (SIMP a b) = liftM2 (||) (not <$> tautology a) (tautology b) tautology (SIMP a b) = liftM2 (||) (not <$> tautology a) (tautology b)
checkTautology s = all ((==True) . fst ) $ runStateT (tautology s) [] checkTautology s = all ((==True) . fst ) $ runStateT (tautology s) []
go s = do go s = do