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))