quickCheck - Lisp のコンス
Lisp のコンスを用いたバージョン。ほぼ PAIP 2.3 を直訳したつもり。
まず実例。ex 、ex' 関数は共に Object -> Object -> IO Object で、QuickCheck の sample' 関数を使っている。ex は文を、ex' は解析木を吐く。
*EnglishRule13> ex simpleGrammar (S "noun") (ball) *EnglishRule13> ex simpleGrammar (S "noun-phrase") (a ball) *EnglishRule13> ex simpleGrammar (S "sentence") (a table linked a man) *EnglishRule13> ex simpleGrammar (S "sentence") (a ball took a woman) *EnglishRule13> ex' bigGrammar (S "noun") (noun woman) *EnglishRule13> ex' bigGrammar (S "sentence") (sentence (noun-phrase (name Lee)) (verb-phrase (verb saw) (noun-phrase (name Kim)) (pp*))) *EnglishRule13> ex' bigGrammar (S "sentence") (sentence (noun-phrase (pronoun these)) (verb-phrase (verb hit) (noun-phrase (article the) (adj* (adj adiabatic) (adj* (adj big) (adj*))) (noun ball) (pp* (pp (prep to) (noun-phrase (article the) (adj* (adj adiabatic) (adj*)) (noun woman) (pp* (pp (prep in) (noun-phrase (name Kim))) (pp* (pp (prep to) (noun-phrase (article a) (adj* (adj adiabatic) (adj* (adj big) (adj*))) (noun ball) (pp* (pp (prep on) (noun-phrase (pronoun he))) (pp* (pp (prep in) (noun-phrase (name Pat))) (pp*))))) (pp* (pp (prep on) (noun-phrase (article the) (adj* (adj little) (adj*)) (noun table) (pp*))) (pp*)))))) (pp* (pp (prep with) (noun-phrase (article the) (adj* (adj adiabatic) (adj* (adj adiabatic) (adj*))) (noun man) (pp*))) (pp*)))) (pp* (pp (prep with) (noun-phrase (pronoun it))) (pp* (pp (prep on) (noun-phrase (name Terry))) (pp* (pp (prep by) (noun-phrase (name Pat))) (pp* (pp (prep on) (noun-phrase (name Pat))) (pp* (pp (prep on) (noun-phrase (name Lee))) (pp* (pp (prep in) (noun-phrase (article a) (adj* (adj blue) (adj* (adj green) (adj* (adj big) (adj*)))) (noun table) (pp* (pp (prep in) (noun-phrase (article a) (adj* (adj little) (adj*)) (noun woman) (pp*))) (pp* (pp (prep with) (noun-phrase (name Kim))) (pp* (pp (prep to) (noun-phrase (name Terry))) (pp* (pp (prep with) (noun-phrase (name Kim))) (pp*))))))) (pp* (pp (prep on) (noun-phrase (pronoun she))) (pp*)))))))))) *EnglishRule13>
リスト操作関数を再実装する手間と型検査の安心感とを犠牲に、Lisp っぽいコードになっている。犠牲にしたものが大きすぎる気もするけど。
モナド版の mapcar', mappend' はもうちょっと共通化できるかもしれない。以下コード。
module EnglishRule13 where import qualified Test.QuickCheck as Q import Control.Monad import Data.List -- 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)) -- | Apply fn to each element of list and append the results. mappend' f list | list == Nil = return Nil | otherwise = liftM2 append (f (car list)) (mappend' f (cdr list)) mapcar f list | list == Nil = Nil | otherwise = cons (f (car list)) (mapcar f (cdr list)) mapcar' f list | list == Nil = return Nil | otherwise = liftM2 cons (f (car list)) (mapcar' f (cdr list)) empty = return Nil :: Q.Gen Object -- | Generate a random sentence or phrase. generate :: Object -> Object -> Q.Gen Object generate grm phrase | listp phrase = mappend' (generate grm) phrase | rewrites grm phrase /= Nil = do y <- randomElt (rewrites grm phrase) generate grm y | otherwise = return $ list1 phrase -- | Generate a random sentence or phrase wiht a complete parse tree. generateTree :: Object -> Object -> Q.Gen Object generateTree grm phrase | listp phrase = mapcar' (generateTree grm) phrase | rewrites grm phrase /= Nil = do y <- randomElt (rewrites grm phrase) t <- generateTree grm y return $ cons phrase t | otherwise = return $ list1 phrase -- | sample data ex grm phrase = do xs <- Q.sample' $ generate grm phrase return $ head xs ex' grm phrase = do xs <- Q.sample' $ generateTree grm phrase return $ head xs -- | 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) bigGrammar = array2list [ d "sentence" [["noun-phrase", "verb-phrase"]], d "noun-phrase" [["article", "adj*", "noun", "pp*"], ["name"], ["pronoun"]], d "verb-phrase" [["verb", "noun-phrase", "pp*"]], d "pp*" [[], ["pp", "pp*"]], d "adj*" [[], ["adj", "adj*"]], d "pp" [["prep", "noun-phrase"]], w "prep" ["to", "in", "by", "with", "on"], w "adj" ["big", "little", "blue", "green", "adiabatic"], w "article" ["the", "a"], w "name" ["Pat", "Kim", "Lee", "Terry", "Robin"], w "noun" ["man", "ball", "woman", "table"], w "verb" ["hit", "took", "saw", "liked"], w "pronoun" ["he", "she", "it", "these", "those", "that"] ] where d x xs = S x :. (S "->" :. array2list (map (array2list . map S) xs)) w x xs = S x :. (S "->" :. array2list (map S xs)) simpleGrammar = array2list [ d "sentence" [["noun-phrase", "verb-phrase"]], d "noun-phrase" [["article", "noun"]], d "verb-phrase" [["verb", "noun-phrase"]], w "article" ["the", "a"], w "noun" ["man", "ball", "woman", "table"], w "verb" ["hit", "took", "saw", "linked"] ] where d x xs = S x :. (S "->" :. array2list (map (array2list . map S) xs)) w x xs = S x :. (S "->" :. array2list (map S xs))