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