S -> A, A -> B, B -> a, it works perfectly and returns S -> a, the problem is when the root symbol is on the listthat must be replaced as in:
S -> aXa | bXb , X -> a | b | S | £(empty)
instead of returning
S -> aXa | bXb, X -> a | b | £ | aXa | bXb
it ruturns X as
X -> a | b | £ | S <- this S is wrong! it should return X -> a | b | £ | aXa | bXb! Im not sure about where is the mistake. If you can give me hints it would be grat. I will be checking the mail and also hanging over #haskell at freenode ifyou want to contact me directly. Thanks in advance for the help!
Victor
module CFG where
import Text.ParserCombinators.Parsec
{--import Data.Map--}
import Control.Monad (liftM)
import Data.Map (Map)
import qualified Data.Map as Map
data CFG t nt = CFG {terminals :: [Symb t nt],
nonterminals :: [Symb t nt],
root :: Symb t nt ,
{-productions :: Map (Symb t nt) [(ProdName,[Symb t nt])]-}
productions :: Map (Symb t nt) [[Symb t nt]]}
deriving (Eq,Ord,Show)
type Prod t nt = (ProdName,[Symb t nt])
type ProdName = String
data Symb t nt = Root
| T t
| NT nt
| Empty
deriving (Eq,Ord,Show)
{-Checks if the non-terminals are oki, the restriction that each NT must consist of a single symbol is already checked by the mapping structure here the only check needed id that the terminals and nonterminals sets are disjunct-}
nonterminal :: [Char] -> CharParser st (Symb Char Char)
nonterminal termchars = liftM NT (noneOf (" |\n"++termchars))
{-Now I try to check if a given symbol is a terminal-}
terminal :: [Char] -> CharParser st (Symb Char Char)
terminal termchars = liftM T (oneOf termchars)
{-Checks if it is a $ production, Ive used $ for empty prodution because GHC doesnt supports unicode YET :-) -}
empty :: CharParser st (Symb Char Char)
empty = do {char '$'; return Empty}
{-rhs termchars = production termchars `sepBy` string " | "-}
{- parseTest (rhs "sz") "sN | z" -}
{- rhs stands for right-hand-side -}
production termchars = (do empty; return [])
<|> many (terminal termchars <|> nonterminal termchars)
rhs termchars = production termchars `sepBy` string " | "
rule termchars = do x <- nonterminal termchars
string " -> "
ys <- rhs termchars
return (x, ys)
{-parseTest grammar (unlines ["termchars sz","start N","N -> sN | z"])-}
grammar = do string "termchars "; termchars <- many (noneOf " |\n"); newline
string "start "; root <- nonterminal termchars; newline
productionsList <- rule termchars `sepEndBy` newline
return (CFG { terminals = map T termchars,
nonterminals = map fst productionsList,
root = root,
productions = Map.fromList productionsList
})
{-let cfg = run grammar "" (unlines ["termchars sz","start N","N -> sN | z"])-}
{-*CFG> let cfg = run grammar "" (unlines ["termchars sz","start N","N -> sN | z"])
Loading package parsec-1.0 ... linking ... done.
*CFG> cfg
CFG {terminals = [T 's',T 'z'], nonterminals = [NT 'N'], root = NT 'N', productions = {NT 'N':=[[T 's',NT 'N'],[T 'z']]}}
*CFG> start
<interactive>:1:0: Not in scope: `start'
*CFG> cfg
CFG {terminals = [T 's',T 'z'], nonterminals = [NT 'N'], root = NT 'N', productions = {NT 'N':=[[T 's',NT 'N'],[T 'z']]}}
*CFG> root cfg
NT 'N'
-}
run p name xs = case parse p name xs of
Left err -> error (show err)
Right res -> res
{-Finds empty productions-}
{- *CFG> let cfg = run grammar "" (unlines ["termchars ab","start S","S -> aXa | bXb | $","X -> a | b | Y","Y -> $"])
*CFG> empties cfg
[NT 'S',NT 'Y'] -}
empties cfg = Map.keys (Map.filter (any (==[])) (productions cfg))
{-cleanset cfg = Map.map ((filter (/=[Empty])) (productions cfg))-}
removeEmpties1 cfg = cfg { productions = prods'' }
where
prods = productions cfg
{-prods' = Map.map (filter (/=[])) prods-}
prods' = Map.mapWithKey (\k -> if k == root cfg
then id
else filter (/=[]))
prods
prods'' = Map.map (concatMap f) prods'
f [] = [[]]
f (x:xs) | x `elem` empties cfg = map (x:) (f xs) ++ f xs
| otherwise = map (x:) (f xs)
removeEmpties :: (Ord t, Ord nt) => CFG t nt -> CFG t nt
removeEmpties = doToDeath removeEmpties1
doToDeath f x = findFixedPoint (iterate f x)
where
findFixedPoint (x:y:z)
| x == y = x
| otherwise = findFixedPoint (y:z)
--remove useless
{-removeUseless (removeEmpties cfg)-}
useless cfg = Map.keys (Map.delete (root cfg)
(Map.filter null (productions cfg)))
removeUseless cfg = cfg { productions = Map.map (map $ concatMap f)
(productions cfg)
`Map.difference`
(Map.fromList $
zip unwanted (repeat ())),
nonterminals = Map.keys (productions cfg) }
where
unwanted = useless cfg
f x | x `elem` unwanted = []
| otherwise = [x]
-- remove replacers
{-let cfg = run grammar "" (unlines ["termchars ab","start S","S -> A","A -> B"])-}
{-removeReplacers cfg
CFG {terminals = [T 'a',T 'b'], nonterminals = [NT 'S',NT 'A'], root = NT 'S', productions = {NT 'A':=[[NT 'B']],NT 'S':=[[NT 'B']]}}-}
replacements :: Ord k => Map k k -> Map k k
replacements rmap = result
where
result = Map.map (\x -> case Map.lookup x result of
Nothing -> x
Just y -> y) rmap
removeReplacers cfg = cfg { productions = prodssimp'',
nonterminals = Map.keys prodssimp''}
where
prodssimp = productions cfg
replacers = Map.map (head . head) (Map.filter isReplacer prodssimp)
isReplacer [[x]] = True
isReplacer _ = False
replace :: (Ord k, Ord a) => Map k [[a]] -> Map a a -> Map k [[a]]
replace prods m = Map.map (map $ map f) prods
where f x = case Map.lookup x m of
Nothing -> x
Just y -> y
prodssimp' = replace prodssimp (replacements replacers)
prodssimp'' = Map.filterWithKey (\k _ -> k == root cfg
|| not (Map.member k replacers))
prodssimp'
_______________________________________________ Haskell-Cafe mailing list Haskell-Cafe@haskell.org http://www.haskell.org/mailman/listinfo/haskell-cafe
