用lisp来让计算机学会写作
大部分的代码、思路参考了《Ansi Common Lisp》P138~P141。
问题：给一篇英文文本，如何让计算机依据此文本而生成随机但可读的文本。如：
|Venture|
The National Venture Capital Association estimates that wealth associated with a deal a big spending by regulations that will spend one another's main reason these projects .
这是计算机学习了Paul Graham的一些文章后生成的随机文本。它根据Venture这个单词向两边延伸成一个句子。令人惊喜的是，文本常常是可读的。
算法：记录每个单词后面出现的单词以及出现的次数，如I leave在原文中出现了5次，I want出现了3次，除此之外，其它地方没有出现过I，所以在生成随机文章的时候，当遇到I，有5/8的概率选择leave为下一个单词。假如选择了leave的话，则看看leave后面出现过哪些单词，重复以上过程。
现用lisp来解决问题。
lisp里的符号类型，即symbol，可以很好记录各种字符串还有标点符号，所以采用它来记录。采用内附的hashtable来建立列表：
(defparameter *words* (make-hash-table :size 10000))
那如何建立列表呢？
(let ((prev '|.|))
(defun see (sym)
(let ((pair (assoc sym (gethash prev *words*))))
(if pair
(incf (cdr pair))
(push (cons sym 1) (gethash prev *words*))))
(setf prev sym)))
以当前单词为keyword，以assoc-list关系列表为该keyword下的值。
如I下有( (|leave| . 5) (|want| . 3) )。没有单词word的话，则push入(word . 1)。
如何随机选一个词呢？
(defun random-word (word ht)
(let* ((choices (gethash word ht))
(x (random (reduce #'+ choices :key #'cdr))))
(dolist (pair choices)
(decf x (cdr pair))
(if (minusp x)
(return (car pair))))))
这里巧妙用了reduce函数。
现在再来思考，如何将给定一个词向两侧延伸成一句话呢？
1）先将文本反向，得到一个反向的列表，也即I leave,I want变成leave I,want I。
2）将hashtable反向，得到另外一个hashtable，以后一个单词为关键字，前面可能出现的单词及次数构成assoc-list。
3）碰运气，从一个标点开始延续文章，直到出现给定单词为止。
我用了第二个方法：
(defparameter *r-words* (make-hash-table :size 10000)) (defun push-words (w1 w2 n) (push (cons w2 n) (gethash w1 *r-words*))) (defun get-reversed-words ();a cat -> cat a (maphash #'(lambda (k lst) (dolist (pair lst) (push-words (car pair) k (cdr pair)))) *words*))
遍历原来的hashtable，再把每一对单词先后换个位置插入另外一个hashtable。
给出双向延伸句子的自动生成文本代码：
(defparameter *words* (make-hash-table :size 10000))
(defconstant maxword 100)
(defparameter nwords 0)
(defconstant debug nil)
(let ((prev '|.|))
(defun see (sym)
(incf nwords)
(let ((pair (assoc sym (gethash prev *words*))))
(if pair
(incf (cdr pair))
(push (cons sym 1) (gethash prev *words*))))
(setf prev sym)))
(defun check-punc (c);char to symbol
(case c
(#\. '|.|) (#\, '|,|)
(#\; '|;|) (#\? '|?|)
(#\: '|:|) (#\! '|!|)))
(defun read-text (pathname)
(with-open-file (str pathname :direction :input)
(let ((buf (make-string maxword))
(pos 0))
(do ((c (read-char str nil 'eof)
(read-char str nil 'eof)))
((eql c 'eof))
(if (or (alpha-char-p c)
(eql c #\'))
(progn
(setf (char buf pos) c)
(incf pos))
(progn
(unless (zerop pos)
(see (intern (subseq buf 0 pos)))
(setf pos 0))
(let ((punc (check-punc c)))
(if punc
(see punc)))))))))
(defun print-ht (ht)
(maphash #'(lambda (k v)
(format t "~A ~A~%" k v))
ht))
(defparameter *r-words* (make-hash-table :size 10000))
(defun push-words (w1 w2 n)
(push (cons w2 n) (gethash w1 *r-words*)))
(defun get-reversed-words ();a cat -> cat a
(maphash #'(lambda (k lst)
(dolist (pair lst)
(push-words (car pair) k (cdr pair))))
*words*))
(defun print-a-word (word ht)
(maphash #'(lambda (k lst)
(if (eql k word)
(format t "~A ~A~%" k lst)))
ht))
(if debug
(print-a-word '|leave| *r-words*))
(defun punc-p (sym);symbol to char,nil when fails.
(check-punc (char (symbol-name sym) 0)))
(defun random-word (word ht)
(let* ((choices (gethash word ht))
(x (random (reduce #'+ choices :key #'cdr))))
(dolist (pair choices)
(decf x (cdr pair))
(if (minusp x)
(return (car pair))))))
(defun gen-former (word str)
(let ((last (random-word word *r-words*)))
(if (not (punc-p last))
(progn
(gen-former last str)
(format str "~A " last)))))
(defun gen-latter (word str)
(let ((next (random-word word *words*)))
(format str "~A " next)
(if (not (punc-p next))
(gen-latter next str))))
;(gen-latter '|leave| t)
(defun get-a-word (ht);get a random word
(let ((x (random nwords)))
(maphash #'(lambda (k v)
(dolist (pair v)
(decf x (cdr pair))
(if (minusp x)
(return-from get-a-word (car pair)))))
ht)))
;(get-a-word *words*)
(defun gen-sentence (word str)
(gen-former word str)
(format str "~A " word)
(gen-latter word str))
(defun test ()
(setf nwords 0)
(read-text "essay.txt")
(get-reversed-words)
(let ((word (get-a-word *words*)))
(print word)
(gen-sentence word t)))
(test)
文本语料库、lisp源代码见： Here