quickCheck - Cons 版
コンスセルを使った版。途中。
module EnglishRule12 where import qualified Test.QuickCheck as Q import Control.Monad import Data.List import Data.Tree -- data data Object = Nil | S String | I Int | Object :. Object deriving (Eq) -- infixr 0 :. instance Show Object where show Nil = "()" show (I x) = show x show (S x) = x show (x :. y) = showCons (x :. y) -- HyperSpec "22.1.3.5 Printing Lists And Conses" showCons x = step1 x "" where step1 x res = step2 x (res ++ "(") step2 x res = step3 x (res ++ show (car x)) step3 x res = if consp (cdr x) then step2 (cdr x) (res ++ " ") else step4 x res step4 x res = if cdr x /= Nil then step5 x (res ++ " . " ++ show (cdr x)) else step5 x res step5 x res = res ++ ")" -- list operator cons = (:.) list1 x = x :. Nil list2 x y = x :. (y :. Nil) list3 x y z = x :. (y :. (z :. Nil)) list4 w x y z = w :. (x :. (y :. (z :. Nil))) consp Nil = False consp (S _) = False consp (I _) = False consp (_ :. _) = True atom Nil = True atom (S _) = True atom (I _) = True atom (_ :. _) = False listp x = consp x || x == Nil car (x :. _) = x car x | not (consp x) = error ("car expect cons but got: " ++ show x) cdr (_ :. y) = y cdr Nil = Nil cdr x | not (consp x) = error ("cdr expect cons but got: " ++ show x) caar x = car (car x) cadr x = car (cdr x) cddr x = cdr (cdr x) assoc :: Object -> Object -> Object assoc item alist | alist == Nil = Nil | not (consp alist) = error ("assoc expect list but got: " ++ show alist) | not (consp (car alist)) = error ("assoc expect cons but got: " ++ show (car alist)) | caar alist == item = car alist | caar alist /= item = assoc item (cdr alist) -- | Utility. Generate Lisp List from Haskell Array array2list = foldr cons Nil list2array Nil = [] list2array (x :. y) | listp y = x : list2array y | otherwise = error ("list2array expect list, but got: " ++ show y) append x y | x == Nil = y | otherwise = cons (car x) (append (cdr x) y) mappend :: (Object -> Object) -> Object -> Object mappend f list | list == Nil = Nil | otherwise = append (f (car list)) (mappend f (cdr list)) type Grammar = Object append' :: Q.Gen Object -> Q.Gen Object -> Q.Gen Object append' x y = do a <- x b <- y return $ append a b empty = return Nil :: Q.Gen Object -- | Generate a random sentence or phrase. generate :: Object -> Object -> Q.Gen Object generate grm phrase | listp phrase = foldr (append' . generate grm) empty (list2array phrase) | rewrites grm phrase /= Nil = do y <- randomElt (rewrites grm phrase) generate grm y | otherwise = return $ list1 phrase generate' :: Object -> Object -> Q.Gen [Object] generate' grm phrase | listp phrase = do ts <- mapM (generate' grm) (list2array phrase) return $ concat ts | rewrites grm phrase /= Nil = do y <- randomElt (rewrites grm phrase) generate' grm y | otherwise = return [list1 phrase] -- | The left-hand side of a rule. ruleLhs = car -- | The right-hand side of a rule. ruleRhs rule = cdr (cdr rule) -- | Return a list of the possible rewrites for this category. rewrites grm category | atom category = ruleRhs (assoc category grm) | otherwise = error ("rewrite got: " ++ show category) -- | Pick an element from a list at random. oneOf set = do x <- randomElt set return $ list1 x -- | Choose an element from a list at random. randomElt :: Object -> Q.Gen Object randomElt choices | listp choices = Q.oneof [Q.elements (list2array choices)] | otherwise = error ("randomElt expect choices but got: " ++ show choices)