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)