SHARE
TWEET

Propositional Formula Parser

Condiamond Mar 21st, 2020 (edited) 130 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. module Main where
  2.  
  3. import Control.Applicative
  4. import Data.Char
  5.  
  6. newtype Parser a = Parser { runParser :: String -> [(a, String)] }
  7. -- The return type of a function wrapped inside a Parser data type is not `Maybe`,
  8. -- but rather a list to provide flexibility to the Parsing object.
  9.  
  10. item :: Parser Char
  11. item = Parser $ \input -> case input of
  12.                               []     -> []
  13.                               (x:xs) -> [(x,xs)]
  14.  
  15. instance Functor Parser where
  16. --  fmap :: (a -> b) -> Parser a -> Parser b
  17.     fmap f p = Parser $ \input -> case runParser p input of
  18.                                       []          -> []
  19.                                       [(v, rest)] -> [(f v, rest)]
  20.  
  21. instance Applicative Parser where
  22. --  pure :: a -> Parser a
  23.     pure x = Parser $ \input -> [(x, input)]
  24. --     <*> :: Parser (a -> b) -> Parser a -> Parser b
  25.     pf <*> pa = Parser $ \input -> case runParser pf input of
  26.                                        []          -> []
  27.                                        [(f, rest)] -> runParser (fmap f pa) rest
  28.  
  29. instance Monad Parser where
  30. --  return :: a -> Parser a
  31.     return = pure
  32. --   (>>=) :: Parser a -> (a -> Parser b) -> Parser b
  33.     p >>= f = Parser $ \input -> case runParser p input of
  34.                                      []          -> []
  35.                                      [(x, rest)] -> runParser (f x) rest
  36.  
  37. instance Alternative Parser where
  38. --  empty :: Parser a
  39.     empty = Parser $ \input -> []
  40.  
  41. --   (<|>) :: Parser a -> Parser a -> Parser a
  42.     p <|> q = Parser $ \input -> case runParser p input of
  43.                                      []         -> runParser q input
  44.                                      [(x, out)] -> [(x, out)]
  45.  
  46. predicate :: (Char -> Bool) -> Parser Char
  47. predicate p = do
  48.     x <- item
  49.     if p x then return x else empty
  50.  
  51. upper :: Parser Char
  52. upper = predicate isUpper
  53.  
  54. alphanum :: Parser Char
  55. alphanum = predicate isAlphaNum
  56.  
  57. restVariable :: Parser Char
  58. restVariable = predicate (\c -> isUpper c || isDigit c || c == '\'')
  59.  
  60. character :: Char -> Parser Char
  61. character x = predicate (== x)
  62.  
  63. string :: String -> Parser String
  64. string []     = return []
  65. string (x:xs) = do
  66.     character x
  67.     string xs
  68.     return $ x:xs
  69.  
  70. chain :: Parser a -> Parser s -> Parser [a]
  71. chain item separator = do
  72.     i  <- item
  73.     is <- many (do
  74.         separator
  75.         item)
  76.     return $ i:is
  77.  
  78. leftAssociative :: (a -> a -> a) -> Parser a -> Parser s -> Parser a
  79. leftAssociative f item separator = do
  80.     is <- chain item separator
  81.     return $ foldl1 f is
  82.  
  83. rightAssociative :: (a -> a -> a) -> Parser a -> Parser s -> Parser a
  84. rightAssociative f item separator = do
  85.     is <- chain item separator
  86.     return $ foldr1 f is
  87.  
  88. -- =========================================== --
  89.  
  90. data Tree
  91.     = Var String
  92.     | Not Tree
  93.     | Conj Tree Tree
  94.     | Disj Tree Tree
  95.     | Impl Tree Tree
  96.  
  97. instance Show Tree where
  98.     show (Var v)    = v
  99.     show (Not t)    = "(!"   ++ show t ++ ")"
  100.     show (Conj x y) = "(&,"  ++ show x ++ "," ++ show y ++ ")"
  101.     show (Disj x y) = "(|,"  ++ show x ++ "," ++ show y ++ ")"
  102.     show (Impl x y) = "(->," ++ show x ++ "," ++ show y ++ ")"
  103.  
  104. implication :: Parser Tree
  105. implication = rightAssociative Impl disjunction (string "->")
  106.  
  107. disjunction :: Parser Tree
  108. disjunction = leftAssociative Disj conjunction (character '|')
  109.  
  110. conjunction :: Parser Tree
  111. conjunction = leftAssociative Conj negation (character '&')
  112.  
  113. negation :: Parser Tree
  114. negation = do
  115.         character '!'
  116.         y <- negation
  117.         return $ Not y
  118.     <|> variable
  119.     <|> do
  120.         character '('
  121.         x <- implication
  122.         character ')'
  123.         return x
  124.  
  125. variable :: Parser Tree
  126. variable = do
  127.     x  <- upper
  128.     xs <- many restVariable
  129.     return . Var $ x:xs
  130.  
  131. -- =========================================== --
  132.  
  133. parse :: String -> Tree
  134. parse given
  135.     = fst
  136.     . head
  137.     . runParser implication
  138.     . filter (not . isSpace)
  139.     $ given
  140.  
  141. main :: IO ()
  142. main = do
  143.     given <- getLine
  144.     print . parse $ given
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Top