home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / games / conx.el < prev    next >
Encoding:
Text File  |  1994-09-20  |  21.4 KB  |  780 lines
  1. ;;; -*- Mode:Emacs-Lisp; Blat:Foop -*-
  2.  
  3. ;;; conx.el: Yet Another Dissociator.
  4. ;;; Original design by Skef Wholey <skef@cs.cmu.edu>;
  5. ;;; ported to Emacs-Lisp by Jamie Zawinski <jwz@lucid.com>, 5-mar-91.
  6. ;;;
  7. (defconst conx-version "1.6,  6-may-94.")
  8. ;;;
  9. ;;; Run this compiled.  It will be an order of magnitude faster.
  10. ;;;
  11. ;;; Select a buffer with a lot of text in it.  Say M-x conx-buffer
  12. ;;; or M-x conx-region.  Repeat on as many other bodies of text as
  13. ;;; you like.
  14. ;;;
  15. ;;; M-x conx will use the word-frequency tree the above generated
  16. ;;; to produce random sentences in a popped-up buffer.  It will pause
  17. ;;; at the end of each paragraph for two seconds; type ^G to stop it.
  18. ;;;
  19. ;;; M-x conx-init will clear the data structures so you can start
  20. ;;; over.  Note that if you run it twice consecutively on the same
  21. ;;; body of text, word sequences in that buffer will be twice as
  22. ;;; likely to be generated.
  23. ;;;
  24. ;;; Once you have sucked in a lot of text and like the kinds of
  25. ;;; sentences conx is giving you, you can save the internal data
  26. ;;; structures to a file with the M-x conx-save command.  Loading
  27. ;;; this file with M-x conx-load will be a lot faster and easier
  28. ;;; than re-absorbing all of the text files.  Beware that loading a
  29. ;;; saved conx-file clears the conx database in memory.
  30. ;;;
  31. ;;; M-x conx-emit-c will write out C source code which, when compiled,
  32. ;;; will produce a standalone program which generates sentences from
  33. ;;; a copy of the database currently loaded.
  34. ;;;
  35. ;;; Ideas for future improvement:
  36. ;;;
  37. ;;;  o  It would be nice if we could load in more than one saved
  38. ;;;     file at a time.
  39. ;;;
  40. ;;;  o  use it to collect statistics on newsgroup conversations by
  41. ;;;     examining the tree for the most common words and phrases
  42. ;;;
  43. ;;;  o  when replying to mail, insert an X-CONX: header field which
  44. ;;;     contains a sentence randomly generated from the body of the
  45. ;;;     message being replied to.
  46. ;;;
  47. ;;;  o  It could stand to be faster...
  48.  
  49. (defvar conx-bounce 10) ; 1/x
  50. (defvar conx-hashtable-size 9923)  ; 9923 is prime
  51. (defconst conx-words-hashtable nil)
  52. (defconst conx-words-vector nil)
  53. (defconst conx-words-vector-fp 0)
  54.  
  55. (defconst conx-last-word nil)
  56.  
  57. (defvar conx-files nil "FYI")
  58.  
  59. (defun conx-init ()
  60.   "Forget the current word-frequency tree."
  61.   (interactive)
  62.   (if (and conx-words-hashtable
  63.        (>= (length conx-words-hashtable) conx-hashtable-size))
  64.       (fillarray conx-words-hashtable 0)
  65.       (setq conx-words-hashtable (make-vector conx-hashtable-size 0)))
  66.   (if conx-words-vector
  67.       (fillarray conx-words-vector nil)
  68.       (setq conx-words-vector (make-vector 1000 nil))) ; this grows
  69.   (setq conx-words-vector-fp 0)
  70.   (setq conx-last-word nil
  71.     conx-files nil))
  72.  
  73. (defun conx-rehash ()
  74.   ;; misnomer; this just grows the linear vector, growing the hash table
  75.   ;; is too hard.
  76.   (message "Rehashing...")
  77.   (let* ((L (length conx-words-vector))
  78.      (v2 (make-vector (+ L L) nil)))
  79.     (while (< 0 L)
  80.       (aset v2 (1- L) (aref conx-words-vector (setq L (1- L)))))
  81.     (setq conx-words-vector v2)
  82.     )
  83.   (message "Rehashing...done"))
  84.  
  85. (defmacro conx-count  (word) (list 'aref word 0))
  86. (defmacro conx-cap    (word) (list 'aref word 1))
  87. (defmacro conx-comma  (word) (list 'aref word 2))
  88. (defmacro conx-period (word) (list 'aref word 3))
  89. (defmacro conx-quem   (word) (list 'aref word 4))
  90. (defmacro conx-bang   (word) (list 'aref word 5))
  91. (defmacro conx-succ   (word) (list 'aref word 6))
  92. (defmacro conx-pred   (word) (list 'aref word 7))
  93. (defmacro conx-succ-c (word) (list 'aref word 8))
  94. (defmacro conx-pred-c (word) (list 'aref word 9))
  95. (defconst conx-length 10)
  96.  
  97. (defmacro conx-make-word ()
  98.   '(copy-sequence '[1 0 0 0 0 0 nil nil 0 0]))
  99.  
  100. (defmacro conx-setf (form val)  ; mind-numbingly simple
  101.   (setq form (macroexpand form (and (boundp 'byte-compile-macro-environment)
  102.                     byte-compile-macro-environment)))
  103.   (cond ((symbolp form) (list 'setq form val))
  104.     ((eq (car form) 'aref) (cons 'aset (append (cdr form) (list val))))
  105.     ((eq (car form) 'cdr) (list 'setcdr (nth 1 form) val))
  106.     ((eq (car form) 'car) (list 'setcar (nth 1 form) val))
  107.     (t (error "can't setf %s" form))))
  108.  
  109. (defmacro conx-push (thing list)
  110.   (list 'conx-setf list (list 'cons thing list)))
  111.  
  112. (defconst conx-most-positive-fixnum (lsh -1 -1)
  113.   "The largest positive integer that can be represented in this emacs.")
  114.  
  115. (defmacro conx-rand (n)
  116.   (list '% (list 'logand 'conx-most-positive-fixnum '(random)) n))
  117.  
  118. (defmacro conx-relate-succ (word related)
  119.   (` (let ((vec (symbol-value (, word))))
  120.        (conx-setf (conx-succ-c vec) (1+ (conx-succ-c vec)))
  121.        (let ((rel (assq (, related) (conx-succ vec))))
  122.      (if rel
  123.          (setcdr rel (1+ (cdr rel)))
  124.          (conx-push (cons (, related) 1) (conx-succ vec)))))))
  125.  
  126. (defmacro conx-relate-pred (word related)
  127.   (` (let ((vec (symbol-value (, word))))
  128.        (conx-setf (conx-pred-c vec) (1+ (conx-pred-c vec)))
  129.        (let ((rel (assq (, related) (conx-pred vec))))
  130.      (if rel
  131.          (setcdr rel (1+ (cdr rel)))
  132.          (conx-push (cons (, related) 1) (conx-pred vec)))))))
  133.  
  134. (defmacro conx-add-word (word)
  135.   (` (let* ((word (, word))
  136.         (fc (aref word 0)))
  137.        (setq word (intern (downcase word) conx-words-hashtable))
  138.        (let ((vec (and (boundp word) (symbol-value word))))
  139.      (if vec
  140.          (conx-setf (conx-count vec) (1+ (conx-count vec)))
  141.        (if (= conx-words-vector-fp (length conx-words-vector))
  142.            (conx-rehash))
  143.        (set word (setq vec (conx-make-word)))
  144.        (aset conx-words-vector conx-words-vector-fp word)
  145.        (setq conx-words-vector-fp (1+ conx-words-vector-fp)))
  146.      (or (< fc ?A) (> fc ?Z)
  147.          (conx-setf (conx-cap vec) (1+ (conx-cap vec)))))
  148.        (if conx-last-word
  149.        (progn
  150.          (conx-relate-succ conx-last-word word)
  151.          (conx-relate-pred word conx-last-word)))
  152.        (setq conx-last-word word))))
  153.  
  154. (defmacro conx-punx (char)
  155.   (` (if conx-last-word
  156.      (let ((char (, char))
  157.            (vec (symbol-value conx-last-word)))
  158.        (cond ((eq char ?\,)
  159.           (conx-setf (conx-comma vec) (1+ (conx-comma vec))))
  160.          ((or (eq char ?\.)
  161.               (eq char ?\;))
  162.           (conx-setf (conx-period vec) (1+ (conx-period vec)))
  163.           (setq conx-last-word nil))
  164.          ((eq char ?\?)
  165.           (conx-setf (conx-quem vec) (1+ (conx-quem vec)))
  166.           (setq conx-last-word nil))
  167.          ((eq char ?\!)
  168.           (conx-setf (conx-bang vec) (1+ (conx-bang vec)))
  169.           (setq conx-last-word nil)))))))
  170.  
  171. (defun conxify-internal ()
  172.   (let (p w)
  173.     (while (not (eobp))
  174.       (skip-chars-forward "^A-Za-z0-9'")
  175.       (while (memq (following-char) '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?\'))
  176.     ;; ignore words beginning with digits
  177.     (skip-chars-forward "A-Za-z0-9'")
  178.     (skip-chars-forward "^A-Za-z0-9'"))
  179.       (setq p (point))
  180.       (skip-chars-forward "A-Za-z0-9'")
  181.       (if (= ?\' (preceding-char)) (forward-char -1))
  182.       (if (eq p (point))
  183.       nil
  184.     (setq w (buffer-substring p (point)))
  185.     (if (equal "nil" w)  ; hey, nil is totally magic, this doesn't work!
  186.         nil
  187.       (conx-add-word w)
  188.       (setq n (1+ n))
  189.       (skip-chars-forward " \t\n\r")
  190.       (if (memq (setq p (following-char)) '(?\, ?\. ?\! ?\? ?\;))
  191.           (conx-punx p)))))))
  192.  
  193. ;;;###autoload
  194. (defun conx-buffer ()
  195.   "Absorb the text in the current buffer into the tree."
  196.   (interactive)
  197.   (or conx-words-vector (conx-init))
  198.   (let ((i conx-words-vector-fp)
  199.     (n 0)
  200.     (pm (point-max)))
  201.     (save-excursion
  202.       (goto-char (point-min))
  203.       (save-restriction
  204.     (widen)
  205.     (while (< (setq p (point)) pm)
  206.       (search-forward "\n\n" pm 0)
  207.       (narrow-to-region p (point))
  208.       (goto-char (prog1 p (setq p (point))))
  209.       (conxify-internal)
  210.       (widen)
  211.       (message "%d%%..." (/ (* p 100) (point-max))))))
  212.     (if buffer-file-name
  213.     (setq conx-files (nconc conx-files (list buffer-file-name))))
  214.     (message "%s words, %d unique" n (- conx-words-vector-fp i))))
  215.  
  216. ;;;###autoload
  217. (defun conx-region (p m)
  218.   "Absorb the text in the current region into the tree."
  219.   (interactive "r")
  220.   (save-restriction
  221.     (widen)
  222.     (narrow-to-region p m)
  223.     (conx-buffer)))
  224.  
  225. (defun conx-mail-buffer ()
  226.   "Conxify a buffer in /bin/mail format."
  227.   (interactive)
  228.   (save-excursion
  229.     (goto-char (point-min))
  230.     (skip-chars-forward "\n \t")
  231.     (let ((case-fold-search nil)
  232.       (buffer-file-name nil)
  233.       p p2 p3)
  234.       (or (looking-at "^From ") (error "not in /bin/mail format"))
  235.       (while (not (eobp))
  236.     (search-forward "\n\n" nil 0)
  237.     (setq p (point))
  238.     (search-forward "\nFrom " nil 0)
  239.     (setq p3 (setq p2 (point)))
  240.     ;; don't count ".signature" sections.
  241.     (and (re-search-backward "\n--+\n" nil t)
  242.          (< (count-lines (point) p2) 9)
  243.          (setq p2 (point)))
  244.     (conx-region p (point))
  245.     (goto-char p3)))
  246.     (if buffer-file-name
  247.     (setq conx-files (nconc conx-files (list buffer-file-name))))
  248.     ))
  249.  
  250. ;;; output
  251.  
  252. (defun conx-random-related (count list)
  253.   (let ((foll (if (= 0 count) 0 (conx-rand count)))
  254.     ans)
  255.     (while list
  256.       (if (<= foll (cdr (car list)))
  257.       (setq ans (car (car list))
  258.         list nil)
  259.       (setq foll (- foll (cdr (car list)))
  260.         list (cdr list))))
  261.     ans))
  262.  
  263. (defun conx-random-succ (word)
  264.   (if (= 0 (conx-succ-c (symbol-value word)))
  265.       word
  266.       (let ((next (conx-random-related
  267.             (conx-succ-c (symbol-value word))
  268.             (conx-succ (symbol-value word)))))
  269.     (if (= 0 (conx-rand conx-bounce))
  270.         (conx-random-succ
  271.           (conx-random-related
  272.         (conx-pred-c (symbol-value next))
  273.         (conx-pred (symbol-value next))))
  274.         next))))
  275.  
  276.  
  277. (defun conx-sentence ()
  278.   (or (> conx-words-vector-fp 0)
  279.       (error "no conx data is loaded; see `conx-buffer'."))
  280.   (let* ((word (aref conx-words-vector (conx-rand conx-words-vector-fp)))
  281.      (first-p t)
  282.      (p (point))
  283.      vec punc str)
  284.     (while word
  285.       (setq punc (conx-rand (conx-count (setq vec (symbol-value word)))))
  286.       (if (or first-p
  287.           ;; (< (conx-rand (conx-count vec)) (conx-cap vec))
  288.           (= (conx-count vec) (conx-cap vec))
  289.           )
  290.       (progn
  291.         (setq first-p nil)
  292.         (setq str (symbol-name word))
  293.         (insert (+ (- ?A ?a) (aref str 0)))
  294.         (insert (substring str 1)))
  295.       (insert (symbol-name word)))
  296.       (cond ((< punc (conx-comma vec))
  297.          (insert ", "))
  298.         ((< (setq punc (- punc (conx-comma vec))) (conx-period vec))
  299.          (setq word nil)
  300.          (if (= 0 (conx-rand 5))
  301.          (if (= 0 (conx-rand 4))
  302.              (insert ": ")
  303.              (insert "; "))
  304.          (insert ".  ")))
  305.         ((< (setq punc (- punc (conx-period vec))) (conx-quem vec))
  306.          (setq word nil)
  307.          (insert "?  "))
  308.         ((< (setq punc (- punc (conx-quem vec))) (conx-bang vec))
  309.          (setq word nil)
  310.          (insert "!  "))
  311.         (t
  312.          (insert " ")
  313.          (if (= 0 (conx-succ-c vec)) (setq word nil))))
  314.       (if word
  315.       (setq word (conx-random-succ word))))
  316.     (fill-region-as-paragraph (save-excursion
  317.                 (goto-char p)
  318.                 (beginning-of-line)
  319.                 (point))
  320.                   (point))
  321.     (if (= (preceding-char) ?\n)
  322.     (if (= 0 (conx-rand 4))
  323.         (insert "\n")
  324.       (delete-char -1)
  325.       (insert "  "))))
  326.   nil)
  327.  
  328. ;;;###autoload
  329. (defun conx ()
  330.   "Generate some random sentences in the *conx* buffer."
  331.   (interactive)
  332.   (display-buffer (set-buffer (get-buffer-create "*conx*")))
  333.   (select-window (get-buffer-window "*conx*"))
  334.   (message "type ^G to stop.")
  335.   (while t
  336.     (goto-char (point-max))
  337.     (sit-for (if (= (preceding-char) ?\n) 2 0))
  338.     (conx-sentence)))
  339.  
  340.  
  341. ;;; GNUS interface; grab words from the current message.
  342.  
  343. (defun conx-gnus-snarf ()
  344.   "For use as a gnus-select-article-hook."
  345.   (set-buffer gnus-article-buffer)
  346.   (save-excursion
  347.     (save-restriction
  348.       (widen)
  349.       (goto-char (point-min))
  350.       (search-forward "\n\n" nil t)
  351.       (conx-region (point) (point-max)))))
  352.  
  353. ;;(add-hook 'gnus-select-article-hook 'conx-gnus-snarf)
  354.  
  355. (defun psychoanalyze-conx ()
  356.   "Mr. Random goes to the analyst."
  357.   (interactive)
  358.   (doctor)                ; start the psychotherapy
  359.   (message "")
  360.   (switch-to-buffer "*doctor*")
  361.   (sit-for 0)
  362.   (while (not (input-pending-p))
  363.     (conx-sentence)
  364.     (if (= (random 2) 0)
  365.     (conx-sentence))
  366.     (sit-for 0)
  367.     (doctor-ret-or-read 1)))
  368.  
  369.  
  370. ;;; Saving the database
  371.  
  372. (defun conx-save (file)
  373.   "Save the current CONX database to a file for future retrieval.
  374. You can re-load this database with the \\[conx-load] command."
  375.   (interactive "FSave CONX corpus to file: ")
  376.   (save-excursion
  377.    (let (b)
  378.     (unwind-protect
  379.       (progn
  380.     (set-buffer (setq b (get-buffer-create "*conx-save-tmp*")))
  381.     (delete-region (point-min) (point-max))
  382.     (insert ";;; -*- Mode:Emacs-Lisp -*-\n")
  383.     (insert ";;; This is a CONX database file.  Load it with `conx-load'.\n")
  384.     (if conx-files
  385.         (insert ";;; Corpus: " (mapconcat 'identity conx-files ", ") "\n"))
  386.     (insert ";;; Date: " (current-time-string) "\n\n")
  387.     ;; The file format used here is such a cute hack that I'm going to
  388.     ;; leave it as an excercise to the reader to figure it out.
  389.     (let ((p (point))
  390.           (fill-column 78)
  391.           (fill-prefix "\t")
  392.           (i 0))
  393.       (insert "(!! [\t")
  394.       (while (< i conx-words-vector-fp)
  395.         (prin1 (aref conx-words-vector i) (current-buffer))
  396.         (insert " ")
  397.         (setq i (1+ i)))
  398.       (insert "])\n")
  399.       (fill-region-as-paragraph p (point))
  400.       (insert "\n"))
  401.     (mapatoms (function (lambda (sym)
  402.             (if (not (boundp sym))
  403.             nil
  404.               (insert "\(! ")
  405.               (prin1 sym (current-buffer))
  406.               (insert " ")
  407.               (prin1 (symbol-value sym) (current-buffer))
  408.               (insert "\)\n"))))
  409.           conx-words-hashtable)
  410.     (goto-char (point-min))
  411.     (while (re-search-forward "\\bnil\\b" nil t)
  412.       (replace-match "()"))
  413.     (set-visited-file-name file)
  414.     (save-buffer)))
  415.     (and b (kill-buffer b)))))
  416.  
  417. ;;;###autoload
  418. (defun conx-load (file)
  419.   "Load in a CONX database written by the \\[conx-save] command.
  420. This clears the database currently in memory."
  421.   (interactive "fLoad CONX corpus from file: ")
  422.   (conx-init)
  423.   (fset (intern "!!" conx-words-hashtable)
  424.     (function (lambda (vec)
  425.       (setq conx-words-vector vec
  426.         conx-words-vector-fp (length vec)))))
  427.   (fset (intern "!" conx-words-hashtable)
  428.     (symbol-function 'setq))
  429.   (let ((obarray conx-words-hashtable))
  430.     (load file)))
  431.  
  432.  
  433. ;;; Emitting C code
  434.  
  435. (defun conx-emit-c-data (&optional ansi-p)
  436.   (let ((all '())
  437.     (standard-output (current-buffer))
  438.     (after-change-functions nil) ; turning off font-lock speeds it up x2
  439.     (before-change-functions nil)
  440.     (after-change-function nil)
  441.     (before-change-function nil)
  442.     (float-output-format "%.2f")
  443.     count total total100)
  444.     (or conx-words-hashtable (error "no words"))
  445.     (let ((i 0))
  446.       (mapatoms (function (lambda (x)
  447.                 (if (boundp x)
  448.                 (setq all (cons (cons i x) all)
  449.                       i (1+ i)))))
  450.         conx-words-hashtable))
  451.     (setq all (nreverse all))
  452.     (setq total (* 4 (length all))
  453.       total100 (max 1 (if (featurep 'lisp-float-type)
  454.                   (/ (float total) 100)
  455.                 (/ total 100)))
  456.       count 0)
  457.     (let ((rest all)
  458.       (i 5)
  459.       rest2
  460.       word)
  461.       (insert "static unsigned short D[] = {")
  462.       (while rest
  463.     (setq word (symbol-value (cdr (car rest))))
  464.     (setq rest2 (conx-pred word))
  465.     (setq count (1+ count))
  466.     (while rest2
  467.       (princ (cdr (car rest2))) (insert ",")
  468.       (princ (car (rassq (car (car rest2)) all)))
  469.       (insert ",")
  470.       (setq i (1+ i))
  471.       (cond ((> i 10)
  472.          (insert "\n")
  473.          (setq i 0)))
  474.       (setq rest2 (cdr rest2)))
  475.     (message "Writing C code... %s%%" (/ count total100))
  476.     (setq count (1+ count))
  477.     (setq rest2 (conx-succ word))
  478.     (while rest2
  479.       (princ (cdr (car rest2)))
  480.       (insert ",")
  481.       (princ (car (rassq (car (car rest2)) all)))
  482.       (insert ",")
  483.       (setq i (1+ i))
  484.       (cond ((> i 10)
  485.          (insert "\n")
  486.          (setq i 0)))
  487.       (setq rest2 (cdr rest2)))
  488.     (message "Writing C code... %s%%" (/ count total100))
  489.     (setq count (1+ count))
  490.     (setq rest (cdr rest))))
  491.     (insert "0};\nstatic char T[] = \"")
  492.     (let ((rest all)
  493.       (i 0) (j 20)
  494.       k word)
  495.       (while rest
  496.     (setq word (symbol-name (cdr (car rest))))
  497.     (setq k (1+ (length word))
  498.           i (+ i k)
  499.           j (+ j k 3))
  500.     (cond ((> j 77)
  501.            (insert (if ansi-p "\"\n\"" "\\\n"))
  502.            (setq j (+ k 3))))
  503.     (insert word)        ; assumes word has no chars needing backslashes
  504.     (insert "\\000")
  505.     (message "Writing C code... %s%%" (/ count total100))
  506.     (setq count (1+ count))
  507.     (setq rest (cdr rest))))
  508.     (insert "\";\nstatic struct conx_word words [] = {")
  509.     (let ((rest all)
  510.       (i 0) (j 0)
  511.       cons name word)
  512.       (while rest
  513.     (setq cons (car rest)
  514.           name (symbol-name (cdr cons))
  515.           word (symbol-value (cdr cons)))
  516.     (insert "{") (princ (conx-count word))
  517.     (insert ",") (princ (conx-cap word))
  518.     (insert ",") (princ (conx-comma word))
  519.     (insert ",") (princ (conx-period word))
  520.     (insert ",") (princ (conx-quem word))
  521.     (insert ",") (princ (conx-bang word))
  522.     (if (null (conx-pred word))
  523.         (insert ",0")
  524.       (insert ",")
  525.       (princ i)
  526.       (setq i (+ i (* 2 (length (conx-pred word))))))
  527.     (if (null (conx-succ word))
  528.         (insert ",0,")
  529.       (insert ",")
  530.       (princ i)
  531.       (insert ",")
  532.       (setq i (+ i (* 2 (length (conx-succ word))))))
  533.     (princ (conx-pred-c word)) (insert ",")
  534.     (princ (conx-succ-c word)) (insert ",")
  535.     (princ j)
  536.     (setq j (+ j (length name) 1))
  537.     (insert (if (cdr rest) (if (= 0 (% (car cons) 2)) "},\n" "},") "}"))
  538.     (message "Writing C code... %s%%" (/ count total100))
  539.     (setq count (1+ count))
  540.     (setq rest (cdr rest))
  541.     ))
  542.     (insert "};\n#define conx_bounce ")
  543.     (princ conx-bounce)
  544.     (insert "\n")
  545.     (message "Writing C code... done.")
  546.     ))
  547.  
  548. (defvar conx-c-prolog "\
  549. #if __STDC__
  550. #include <stddef.h>
  551. #include <unistd.h>
  552. extern long random (void);
  553. extern void srandom (int);
  554. extern void abort (void);
  555. #endif
  556. #include <stdio.h>
  557. #include <time.h>
  558.  
  559. struct conx_word {
  560.   unsigned short count;
  561.   unsigned short cap;
  562.   unsigned short comma;
  563.   unsigned short period;
  564.   unsigned short quem;
  565.   unsigned short bang;
  566.   unsigned short pred;
  567.   unsigned short succ;
  568.   unsigned short npred;
  569.   unsigned short nsucc;
  570.   unsigned short text;
  571. };
  572. ")
  573.  
  574. (defvar conx-c-code "\
  575. #define countof(x) (sizeof((x)) / sizeof(*(x)))
  576. #define conx_rand(n) (random()%(n))
  577.  
  578. static struct conx_word *
  579. conx_random_related (count, which_list)
  580.      unsigned short count, which_list;
  581. {
  582.   unsigned short *list = D + which_list;
  583.   int i = 0;
  584.   unsigned short foll = (count == 0 ? 0 : conx_rand (count));
  585.   while (1)
  586.     {
  587.       if (foll <= list [i * 2])
  588.     {
  589.       if ((list [i * 2 + 1]) > countof (words))
  590.         abort ();
  591.       return &words [list [i * 2 + 1]];
  592.     }
  593.       foll -= list [i * 2];
  594.       i++;
  595.     }
  596. }
  597.  
  598. static struct conx_word *
  599. conx_random_succ (word)
  600.      struct conx_word *word;
  601. {
  602.   if (word->nsucc == 0)
  603.     return word;
  604.   else
  605.     {
  606.       struct conx_word *next = conx_random_related (word->nsucc, word->succ);
  607.       if (conx_rand (conx_bounce) != 0)
  608.     return next;
  609.       return conx_random_succ (conx_random_related (next->npred, next->pred));
  610.     }
  611. }
  612.  
  613. static void
  614. conx_sentence ()
  615. {
  616.   static int x = 0;
  617.   struct conx_word *word = 0;
  618.   int first_p = 1;
  619.   int done = 0;
  620.   int count = 0;
  621.   while (!done)
  622.     {
  623.       int punc;
  624.       char *text;
  625.       int L;
  626.       if (word)
  627.     word = conx_random_succ (word);
  628.       else
  629.     word = &words [conx_rand (countof (words))];
  630.       count++;
  631.       punc = conx_rand (word->count);
  632.       text = T + word->text;
  633.       L = strlen (text);
  634.       if (x + L > 70)
  635.     {
  636.       putchar ('\\n');
  637.       x = 0;
  638.     }
  639.       x += L+1;
  640.  
  641.       if (first_p || (word->count == word->cap))
  642.     {
  643.       putchar ((*text >= 'a' && *text <= 'z') ? *text + ('A'-'a') : *text);
  644.       fputs (text+1, stdout);
  645.       first_p = 0;
  646.     }
  647.       else
  648.     fputs (text, stdout);
  649.  
  650.       if (punc < word->comma)
  651.     {
  652.       fputs (\", \", stdout);
  653.       x++;
  654.     }
  655.       else if ((punc -= word->comma) < word->period)
  656.     {
  657.       x++;
  658.       if (count > 120 || conx_rand (5) != 0)
  659.         {
  660.           done = 1;
  661.           fputs (\".  \", stdout);
  662.           x++;
  663.         }
  664.       else
  665.         {
  666.           word = 0;
  667.           if (conx_rand (4) == 0)
  668.         fputs (\": \", stdout);
  669.           else
  670.         fputs (\"; \", stdout);
  671.         }
  672.     }
  673.       else if ((punc -= word->period) < word->quem)
  674.     {
  675.       done = 1;
  676.       fputs (\"?  \", stdout);
  677.       x += 2;
  678.     }
  679.       else if ((punc -= word->quem) < word->bang)
  680.     {
  681.       done = 1;
  682.       fputs (\"!  \", stdout);
  683.       x += 2;
  684.     }
  685.       else
  686.     {
  687.       if (word->nsucc == 0)
  688.         {
  689.           fputs (\".  \", stdout);
  690.           x += 2;
  691.           done = 1;
  692.         }
  693.       else
  694.         putchar (' ');
  695.     }
  696.     }
  697.   if (conx_rand (3) == 0)
  698.     {
  699.       fputs (\"\\n\\n\", stdout);
  700.       x = 0;
  701.     }
  702. }
  703.  
  704. main (argc, argv)
  705.      int argc;
  706.      char **argv;
  707. {
  708.   unsigned int howmany, delay;
  709.   char dummy;
  710.   if (argc == 1)
  711.     {
  712.       howmany = 1;
  713.       delay = 0;
  714.     }
  715.   else if (argc == 2 &&
  716.       1 == sscanf (argv[1], \"%ud%c\", &howmany, &dummy))
  717.     delay = 0;
  718.   else if (argc == 3 &&
  719.        1 == sscanf (argv[1], \"%ud%c\", &howmany, &dummy) &&
  720.        1 == sscanf (argv[2], \"%ud%c\", &delay, &dummy))
  721.     ;
  722.   else
  723.     {
  724.       fprintf (stderr, \"usage: %s [count [delay]]\\n\", argv [0]);
  725.       exit (1);
  726.     }
  727.  
  728.   srandom (time (0));
  729.   if (howmany == 0)
  730.     howmany = ~0;
  731.   while (howmany > 0)
  732.     {
  733.       conx_sentence ();
  734.       fflush (stdout);
  735.       howmany--;
  736.       if (delay) sleep (delay);
  737.     }
  738.   putchar ('\\n');
  739.   exit (0);
  740. }
  741. ")
  742.  
  743. (defun conx-emit-c (file &optional non-ansi-p)
  744.   "Write the current CONX database to a file as C source code.
  745. The generated program will have the same effect as M-x conx,
  746. except that it runs without emacs.
  747.  
  748. With a prefix argument, write K&R C instead of ANSI C.  ANSI is
  749. the default because, without a certain ANSI feature, large databases
  750. will overflow static limits in most K&R preprocessors."
  751.   (interactive "FWrite C file: \nP")
  752.   (find-file file)
  753.   (erase-buffer)
  754.   (let ((buffer-undo-list t))
  755.     (insert conx-c-prolog)
  756.     (if (not non-ansi-p)
  757.     (insert "\n#if !__STDC__\n"
  758.         "error! this file requires an ANSI C compiler\n"
  759.         "#endif\n\n"))
  760.     (conx-emit-c-data (not non-ansi-p))
  761.     (insert conx-c-code))
  762.   (goto-char (point-min)))
  763.  
  764.  
  765. ;;; Reporting stats
  766.  
  767. (defun conx-stats ()
  768.   (set-buffer (get-buffer-create "*conx-stats*"))
  769.   (delete-region (point-min) (point-max))
  770.   (mapatoms (function (lambda (x)
  771.           (or (not (boundp x))
  772.           (progn
  773.             (insert (format "%s" (conx-count (symbol-value x))))
  774.             (insert "\t\t")
  775.             (insert (symbol-name x))
  776.             (insert "\n")))))
  777.         conx-words-hashtable)
  778.   (sort-numeric-fields -1 (point-min) (point-max)))
  779.  
  780.