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