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