quickCheck 英文生成
まだバグがあるが改良版。
module EnglishRule7 where import Test.QuickCheck import Control.Monad import Data.List -- data type Name = String data Rule = Word [String] | Rule [[String]] deriving (Eq, Show) type Grammar = [(String, Rule)] simpleGrammar = [ ("sentence", Rule [["noun-phrase", "verb-phrase"]]), ("article", Word ["the", "a"]), ("noun", Word ["man", "ball", "woman", "table"]), ("verb", Word ["hit", "took", "saw", "liked"] ), ("noun-phrase", Rule [["article", "noun"]]), ("verb-phrase", Rule [["verb", "noun-phrase"]]) ] :: Grammar bigGrammar = [ ("sentence", Rule [["noun-phrase", "verb-phrase"]]), ("noun-phrase", Rule [["article", "adj*", "noun", "pp*"], ["name"], ["pronoun"]]), ("verb-phrase", Rule [["verb", "noun-phrase", "pp*"]]), ("pp*", Rule [[], ["pp", "pp*"]]), ("adj*", Rule [[], ["adj", "adj*"]]), ("pp", Rule [["prep", "noun-phrase"]]), ("prep", Word ["to", "in", "by", "with", "on"]), ("adj", Word ["big", "little", "blue", "green", "adiabatic"]), ("article", Word ["the", "a"]), ("name", Word ["Pat", "Kim", "Lee", "Terry", "Robin"]), ("noun", Word ["man", "ball", "woman", "table"]), ("verb", Word ["hit", "took", "saw", "liked"]), ("pronoun", Word ["he", "she", "it", "these", "those", "that"]) ] :: Grammar mkgen :: Grammar -> String -> Gen String mkgen grm k = case lookup k grm of Just r -> mkgen' grm k r Nothing -> error $ "key not found: " ++ k mkgen' grm x (Word ws) = elements ws mkgen' grm x (Rule rs) = oneof $ map (rule2gen grm x) rs rule2gen :: Grammar -> String -> [String] -> Gen String rule2gen grm x [] = return "" rule2gen grm x (r:rs) = mkgen grm r `catgen` rule2gen grm x rs catgen :: Gen String -> Gen String -> Gen String catgen g1 g2 = do s1 <- g1 s2 <- g2 return $ catWords s1 s2 catWords "" "" = "" catWords x "" = x catWords "" y = y catWords x y = x ++ " " ++ y -- data Tree = EmptyNode | Node String String | Tree String Tree Tree deriving (Eq) instance Show Tree where show (Node n x) = "(" ++ n ++ " " ++ x ++ ")" show EmptyNode = "()" show (Tree "" t1 EmptyNode) = "(" ++ show t1 ++ ")" show (Tree "" EmptyNode t2) = "(" ++ show t2 ++ ")" show (Tree "" t1 t2) = "(" ++ show t1 ++ " " ++ show t2 ++ ")" show (Tree n t1 EmptyNode) = "(" ++ n ++ " " ++ show t1 ++ ")" show (Tree n EmptyNode t2) = "(" ++ n ++ " " ++ show t2 ++ ")" show (Tree n t1 t2) = "(" ++ n ++ " " ++ show t1 ++ " " ++ show t2 ++ ")" mkgenTree :: Grammar -> String -> Gen Tree mkgenTree grm k = case lookup k grm of Just r -> mkgenTree' grm k r Nothing -> error $ "key not found: " ++ k mkgenTree' grm x (Word ws) = do s <- elements ws return $ Node x s mkgenTree' grm x (Rule rs) = oneof $ map (rule2gentree grm x) rs rule2gentree :: Grammar -> String -> [String] -> Gen Tree rule2gentree grm x [] = return EmptyNode rule2gentree grm x (r:rs) = catgentree x (mkgenTree grm r) (rule2gentree grm x rs) catgentree :: String -> Gen Tree -> Gen Tree -> Gen Tree catgentree x g1 g2 = do s1 <- g1 s2 <- g2 if (s1 == EmptyNode && s2 == EmptyNode) then return EmptyNode else if (s1 /= EmptyNode && s2 == EmptyNode) then return s1 else if (s1 == EmptyNode && s2 /= EmptyNode) then return s2 else return $ Tree x s1 s2