BNF2Props.hs

module BNF2Props where

import Parser
import Control.Applicative
import Data.Char
import Data.Maybe
--import Text.Parsec.String.Parsec (parse)

{-

 <syntax>         ::= <rule> | <rule> <syntax>
 <rule>           ::= <opt-whitespace> "<" <rule-name> ">" <opt-whitespace> "::=" <opt-whitespace> <expression> <line-end>
 <opt-whitespace> ::= " " <opt-whitespace> | ""
 <expression>     ::= <list> | <list> <opt-whitespace> "|" <opt-whitespace> <expression>
 <line-end>       ::= <opt-whitespace> <EOL> | <line-end> <line-end>
 <list>           ::= <term> | <term> <opt-whitespace> <list>
 <term>           ::= <literal> | "<" <rule-name> ">"
 <literal>        ::= '"' <text1> '"' | "'" <text2> "'"
 <text1>          ::= "" | <character1> <text1>
 <text2>          ::= "" | <character2> <text2>
 <character>      ::= <letter> | <digit> | <symbol>
 <letter>         ::= "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" | "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"
 <digit>          ::= "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9"
 <symbol>         ::=  "|" | " " | "-" | "!" | "#" | "$" | "%" | "&" | "(" | ")" | "*" | "+" | "," | "-" | "." | "/" | ":" | ";" | ">" | "=" | "<" | "?" | "@" | "[" | "\" | "]" | "^" | "_" | "`" | "{" | "}" | "~"
 <character1>     ::= <character> | "'"
 <character2>     ::= <character> | '"'
 <rule-name>      ::= <letter> | <rule-name> <rule-char>
 <rule-char>      ::= <letter> | <digit> | "-"
-}

syntax' :: Parser [(String, [String])]
syntax' = rule' >>= \r -> (syntax' >>= \s -> return (r : s)) <|> return [r]

rule' :: Parser (String, [String])
rule' = opt_whitespace >> (char '<') >> rule_name >>= \rn -> (char '>') >> opt_whitespace >> (string "::=") >> opt_whitespace >> expression' >>= \e -> line_end >> return ("<" ++ rn ++ ">", e)

expression' :: Parser [String]
expression' = list >>= \l -> (opt_whitespace >> (char '|') >> opt_whitespace >> expression' >>= \e -> return (l : e)) <|> return [l]

syntax, rule, expression, list, term, literal, text1, text2, rule_name :: Parser String
syntax = rule >>= \r -> syntax >>= \s -> return (r ++ s) <|> return r
rule = opt_whitespace >> (char '<') >> rule_name >>= \rn -> (char '>') >> opt_whitespace >> (string "::=") >> opt_whitespace >> expression >>= \e -> line_end >> return ("<" ++ rn ++ "> ::= " ++ e)
expression = list >>= \l -> (opt_whitespace >> (char '|') >> opt_whitespace >> expression >>= \e -> return (l ++ " | " ++ e)) <|> return l
list = term >>= \t -> (opt_whitespace >> list >>= \l -> return (t ++ " " ++ l)) <|> return t
term = literal <|> (string "<" >> rule_name >>= \rn -> string ">" >> return ('<' : rn ++ ">"))
literal = (f >> text1 >>= \t1 -> f >> return ('\"' : t1 ++ ['\"'])) <|> (g >> text2 >>= \t2 -> g >> return ('\'' : t2 ++ ['\'']))
  where f = char '\"' ; g = char '\''
text1 = many character1
text2 = many character2
rule_name = letter >>= \x -> many rule_char >>= \xs -> return (x:xs)


symbol', character, character1, character2, rule_char :: Parser Char

symbol' = token f where f = sat (\c -> isAscii c && not (isAlphaNum c) && c /= '\"' && c /= '\'')
character = letter <|> digit <|> symbol'
character1 = character <|> char '\''
character2 = character <|> char '\"'
rule_char = letter <|> digit <|> char '-'


loe, line_end, opt_whitespace :: Parser ()

loe = sat (\x -> x == '\n') >> return ()
line_end = some (token loe) >> return ()
opt_whitespace = space

{-

"<expression> ::= <term> | <expression> '+' <term> | <expression> '-' <term>\n"
"<term> ::= <factor> | '-' <factor> | <term> '*' <factor> | <term> '/' <factor>\n"
"<factor> ::= <variable> | <constant> | '(' <expression> ')'\n"
"<variable> ::= <letter> | <variable> <letter> | <variable> <digit>\n"
"<letter> ::= 'a' | 'b' | 'c'\n"
"<constant> ::= <digit> | <constant> | <digit>\n"
"<digit> ::= '0' | '1'\n"

-------------------------------------------------------------------------

上記の文法のパタンは以下の通り．ただし，S,Tは非終端記号，a, bは終端記号である．

-- A. S -> T
-- B. S -> SaT
-- C. S -> aT
-- D. S -> aTb
-- E. S -> ST
-- F. S -> a
-- G. S -> S

生成される命題のパタンは以下の通り．ただし，x, y は終端記号である．

-- Tx -> Sx       (from A, E)
-- xT -> xS       (from A)
-- Sx -> xa       (from B)
-- xT -> ax       (from B, C)
-- xS -> ax       (from C)
--    -> aS       (from C, D, F)
--    -> Sb       (from D)
-- xT -> ax       (from D)
-- Tx -> xb       (from D)
-- Sx ∧ yT -> xy  (from E)
--    -> Sa       (from F)
-}

isA, isB, isC, isD, isE, isF :: String -> String -> Bool
isA _ t = if Nothing /= p then null x2 else False
  where p = parse (string "<" >> rule_name >>= \rn -> string ">" >> return ('<' : rn ++ ">")) t ; x2 = snd (fromJust p)
isB s t = if Nothing /= p then if null x2 then s == x1 else False else False
  where p = parse (term >>= \t1 -> opt_whitespace >> literal >> opt_whitespace >> term >> return t1) t
        x1 = fst (fromJust p) ; x2 = snd (fromJust p)
isC _ t = if Nothing /= p then (null . snd . fromJust) p else False
  where p = parse (literal >> opt_whitespace >> term) t
isD _ t = if Nothing /= p then (null . snd . fromJust) p else False
  where p = parse (literal >> opt_whitespace >> term >> opt_whitespace >> literal) t
isE _ t = if Nothing /= p then (null . snd . fromJust) p else False
  where p = parse (term >> opt_whitespace >> term) t
isF _ t = if Nothing /= p then (null . snd . fromJust) p else False
  where p = parse literal t

getInfoB :: String -> (Char,String)
getInfoB s = fst $ fromJust $ parse (term >> (token squoted) >>= \c -> term >>= \t -> return (c,t)) s

getInfoC :: String -> (Char, String)
getInfoC s = fst $ fromJust $ parse ((token squoted) >>= \c -> term >>= \t -> return (c,t)) s

getInfoD :: String -> (Char,String, Char)
getInfoD s = fst $ fromJust $ parse ((token squoted) >>= \c1 -> term >>= \t -> (token squoted) >>= \c2 -> return (c1,t,c2)) s

getInfoE :: String -> (String,String)
getInfoE s = fst $ fromJust $ parse (term >>= \t -> opt_whitespace >> term >>= \u -> return (t,u)) s

getInfoF :: String -> Char
getInfoF s = fst $ fromJust $ parse (token quoted) s

newtype NonTerminalSymbol = NT String deriving (Eq, Ord)
newtype TerminalSymbol = T Char deriving (Eq, Ord)

instance Show NonTerminalSymbol where show (NT s) = s
instance Show TerminalSymbol where show (T c) = '\'':c:['\'']

data Prop = PXx NonTerminalSymbol TerminalSymbol
  | PxX TerminalSymbol NonTerminalSymbol
  | Pxy TerminalSymbol TerminalSymbol
  deriving (Eq, Ord)

instance Show Prop where
  show (PXx n t) = show n ++ " " ++ show t
  show (PxX t n) = show t ++ " " ++ show n
  show (Pxy (T s) (T t)) = s:[t]

-- p1 = PXx (NT "<expression>") (T ')')
-- p2 = PxX (T '(') (NT "<expression>")
-- p3 = Pxy (T '0') (T '1')

data Clause = C { left :: [Prop], right :: Prop } deriving (Eq, Ord)

instance Show Clause where
  show (C l r) = showPropList l ++ " ⇒ " ++ show r
    where showPropList []     = ""
          showPropList [x] = show x
          showPropList (x:xs) = show x ++ " ∧ " ++ showPropList xs

-- c1 = C [p1,p2] p3

predicates = [isA, isB, isC, isD, isE, isF]

rule2clauses :: String -> String -> [Char] -> [Clause]
rule2clauses s t xs = case alph of
  'A' ->
    [C [PXx (NT t) (T x)] (PXx (NT s) (T x)) | x <- xs] ++
    [C [PxX (T x) (NT t)] (PxX (T x) (NT s)) | x <- xs]
  'B' -> let (a,t') = getInfoB t in
    [C [PXx (NT s) (T x)] (Pxy (T x)  (T a)) | x <- xs] ++
    [C [PxX (T x) (NT t')] (Pxy (T a) (T x)) | x <- xs]
  'C' -> let (a,t') = getInfoC t in
    (C [] (PxX (T a)  (NT s))) :
    [C [PxX (T x) (NT s)] (Pxy (T a) (T x)) | x <- xs] ++
    [C [PxX (T x) (NT t')] (Pxy (T a) (T x)) | x <- xs]
  'D' -> let (a,t',b) = getInfoD t in
    (C [] (PxX (T a) (NT s))) :
    (C [] (PXx (NT s) (T b))) :
    [C [PxX (T x) (NT t')] (Pxy (T a) (T x)) | x <- xs] ++
    [C [PXx (NT t') (T x)] (Pxy (T x) (T b)) | x <- xs]
  'E' -> let (s',t') = getInfoE t in
    [C [PXx (NT s') (T x), PxX (T y) (NT t')] (Pxy (T x) (T y)) | x <- xs, y <- xs] ++
    [C [PXx (NT t') (T x)] (PXx (NT s) (T x)) | x <- xs]
  'F' -> let a = getInfoF t in
    [C [] (PXx (NT s) (T a)), C [] (PxX (T a) (NT s))]
  _ -> []
  where alph = fst $ head $ filter (\(x,y) -> y) $ zip ['A'..] [ p s t | p <- predicates ]

-- mapM_ print $ rule2clauses "<factor>" "'(' <expression> ')'" "01"