|
14
|
1 ;;; decipher.el --- Cryptanalyze monoalphabetic substitution ciphers
|
|
|
2 ;;
|
|
|
3 ;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
|
|
|
4 ;;
|
|
|
5 ;; Author: Christopher J. Madsen <ac608@yfn.ysu.edu>
|
|
|
6 ;; Keywords: games
|
|
|
7 ;;
|
|
|
8 ;; This file is part of GNU Emacs.
|
|
|
9 ;;
|
|
|
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
11 ;; it 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 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
18 ;; GNU General Public License for more details.
|
|
|
19 ;;
|
|
|
20 ;; You should have received a copy of the GNU General Public License
|
|
|
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
23 ;; Boston, MA 02111-1307, USA.
|
|
|
24
|
|
|
25 ;;; Quick Start:
|
|
|
26 ;;
|
|
|
27 ;; To decipher a message, type or load it into a buffer and type
|
|
|
28 ;; `M-x decipher'. This will format the buffer and place it into
|
|
|
29 ;; Decipher mode. You can save your work to a file with the normal
|
|
|
30 ;; Emacs save commands; when you reload the file it will automatically
|
|
|
31 ;; enter Decipher mode.
|
|
|
32 ;;
|
|
|
33 ;; I'm not going to discuss how to go about breaking a cipher; try
|
|
|
34 ;; your local library for a book on cryptanalysis. One book you might
|
|
|
35 ;; find is:
|
|
|
36 ;; Cryptanalysis: A study of ciphers and their solution
|
|
|
37 ;; Helen Fouche Gaines
|
|
|
38 ;; ISBN 0-486-20097-3
|
|
|
39
|
|
|
40 ;;; Commentary:
|
|
|
41 ;;
|
|
|
42 ;; This package is designed to help you crack simple substitution
|
|
|
43 ;; ciphers where one letter stands for another. It works for ciphers
|
|
|
44 ;; with or without word divisions. (You must set the variable
|
|
|
45 ;; decipher-ignore-spaces for ciphers without word divisions.)
|
|
|
46 ;;
|
|
|
47 ;; First, some quick definitions:
|
|
|
48 ;; ciphertext The encrypted message (what you start with)
|
|
|
49 ;; plaintext The decrypted message (what you are trying to get)
|
|
|
50 ;;
|
|
|
51 ;; Decipher mode displays ciphertext in uppercase and plaintext in
|
|
|
52 ;; lowercase. You must enter the plaintext in lowercase; uppercase
|
|
|
53 ;; letters are interpreted as commands. The ciphertext may be entered
|
|
|
54 ;; in mixed case; `M-x decipher' will convert it to uppercase.
|
|
|
55 ;;
|
|
|
56 ;; Decipher mode depends on special characters in the first column of
|
|
|
57 ;; each line. The command `M-x decipher' inserts these characters for
|
|
|
58 ;; you. The characters and their meanings are:
|
|
|
59 ;; ( The plaintext & ciphertext alphabets on the first line
|
|
|
60 ;; ) The ciphertext & plaintext alphabets on the second line
|
|
|
61 ;; : A line of ciphertext (with plaintext below)
|
|
|
62 ;; > A line of plaintext (with ciphertext above)
|
|
|
63 ;; % A comment
|
|
|
64 ;; Each line in the buffer MUST begin with one of these characters (or
|
|
|
65 ;; be left blank). In addition, comments beginning with `%!' are reserved
|
|
|
66 ;; for checkpoints; see decipher-make-checkpoint & decipher-restore-checkpoint
|
|
|
67 ;; for more information.
|
|
|
68 ;;
|
|
|
69 ;; While the cipher message may contain digits or punctuation, Decipher
|
|
|
70 ;; mode will ignore these characters.
|
|
|
71 ;;
|
|
|
72 ;; The buffer is made read-only so it can't be modified by normal
|
|
|
73 ;; Emacs commands.
|
|
|
74 ;;
|
|
|
75 ;; Decipher supports Font Lock mode. To use it, you can also add
|
|
|
76 ;; (add-hook 'decipher-mode-hook 'turn-on-font-lock)
|
|
|
77 ;; See the variable `decipher-font-lock-keywords' if you want to customize
|
|
|
78 ;; the faces used. I'd like to thank Simon Marshall for his help in making
|
|
|
79 ;; Decipher work well with Font Lock.
|
|
|
80
|
|
|
81 ;;; Things To Do:
|
|
|
82 ;;
|
|
|
83 ;; Email me if you have any suggestions or would like to help.
|
|
|
84 ;; But be aware that I work on Decipher only sporadically.
|
|
|
85 ;;
|
|
|
86 ;; 1. The consonant-line shortcut
|
|
|
87 ;; 2. More functions for analyzing ciphertext
|
|
|
88
|
|
|
89 ;;;===================================================================
|
|
|
90 ;;; Variables:
|
|
|
91 ;;;===================================================================
|
|
|
92
|
|
|
93 (eval-when-compile
|
|
|
94 (require 'cl))
|
|
|
95
|
|
|
96 (defvar decipher-force-uppercase t
|
|
|
97 "*Non-nil means to convert ciphertext to uppercase.
|
|
|
98 Nil means the case of the ciphertext is preserved.
|
|
|
99 This variable must be set before typing `\\[decipher]'.")
|
|
|
100
|
|
|
101 (defvar decipher-ignore-spaces nil
|
|
|
102 "*Non-nil means to ignore spaces and punctuation when counting digrams.
|
|
|
103 You should set this to `nil' if the cipher message is divided into words,
|
|
|
104 or `t' if it is not.
|
|
|
105 This variable is buffer-local.")
|
|
|
106 (make-variable-buffer-local 'decipher-ignore-spaces)
|
|
|
107
|
|
|
108 (defvar decipher-undo-limit 5000
|
|
|
109 "The maximum number of entries in the undo list.
|
|
|
110 When the undo list exceeds this number, 100 entries are deleted from
|
|
|
111 the tail of the list.")
|
|
|
112
|
|
|
113 ;; End of user modifiable variables
|
|
|
114 ;;--------------------------------------------------------------------
|
|
|
115
|
|
|
116 (defvar decipher-font-lock-keywords
|
|
|
117 '(("^:.*" . font-lock-keyword-face)
|
|
|
118 ("^>.*" . font-lock-string-face)
|
|
|
119 ("^%!.*" . font-lock-reference-face)
|
|
|
120 ("^%.*" . font-lock-comment-face)
|
|
|
121 ("\\`(\\([a-z]+\\) +\\([A-Z]+\\)"
|
|
|
122 (1 font-lock-string-face)
|
|
|
123 (2 font-lock-keyword-face))
|
|
|
124 ("^)\\([A-Z ]+\\)\\([a-z ]+\\)"
|
|
|
125 (1 font-lock-keyword-face)
|
|
|
126 (2 font-lock-string-face)))
|
|
|
127 "Expressions to fontify in Decipher mode.
|
|
|
128 Ciphertext uses `font-lock-keyword-face', plaintext uses
|
|
|
129 `font-lock-string-face', comments use `font-lock-comment-face', and
|
|
|
130 checkpoints use `font-lock-reference-face'. You can customize the
|
|
|
131 display by changing these variables. For best results, I recommend
|
|
|
132 that all faces use the same background color.
|
|
|
133 For example, to display ciphertext in the `bold' face, use
|
|
|
134 (add-hook 'decipher-mode-hook
|
|
|
135 (lambda () (set (make-local-variable 'font-lock-keyword-face)
|
|
|
136 'bold)))
|
|
|
137 in your `.emacs' file.")
|
|
|
138
|
|
|
139 (defvar decipher-mode-map nil
|
|
|
140 "Keymap for Decipher mode.")
|
|
|
141 (if (not decipher-mode-map)
|
|
|
142 (progn
|
|
|
143 (setq decipher-mode-map (make-keymap))
|
|
|
144 (suppress-keymap decipher-mode-map)
|
|
|
145 (define-key decipher-mode-map "A" 'decipher-show-alphabet)
|
|
|
146 (define-key decipher-mode-map "C" 'decipher-complete-alphabet)
|
|
|
147 (define-key decipher-mode-map "D" 'decipher-digram-list)
|
|
|
148 (define-key decipher-mode-map "F" 'decipher-frequency-count)
|
|
|
149 (define-key decipher-mode-map "M" 'decipher-make-checkpoint)
|
|
|
150 (define-key decipher-mode-map "N" 'decipher-adjacency-list)
|
|
|
151 (define-key decipher-mode-map "R" 'decipher-restore-checkpoint)
|
|
|
152 (define-key decipher-mode-map "U" 'decipher-undo)
|
|
|
153 (define-key decipher-mode-map " " 'decipher-keypress)
|
|
|
154 (substitute-key-definition 'undo 'decipher-undo
|
|
|
155 decipher-mode-map global-map)
|
|
|
156 (substitute-key-definition 'advertised-undo 'decipher-undo
|
|
|
157 decipher-mode-map global-map)
|
|
|
158 (let ((key ?a))
|
|
|
159 (while (<= key ?z)
|
|
|
160 (define-key decipher-mode-map (vector key) 'decipher-keypress)
|
|
|
161 (incf key)))))
|
|
|
162
|
|
|
163 (defvar decipher-stats-mode-map nil
|
|
|
164 "Keymap for Decipher-Stats mode.")
|
|
|
165 (if (not decipher-stats-mode-map)
|
|
|
166 (progn
|
|
|
167 (setq decipher-stats-mode-map (make-keymap))
|
|
|
168 (suppress-keymap decipher-stats-mode-map)
|
|
|
169 (define-key decipher-stats-mode-map "D" 'decipher-digram-list)
|
|
|
170 (define-key decipher-stats-mode-map "F" 'decipher-frequency-count)
|
|
|
171 (define-key decipher-stats-mode-map "N" 'decipher-adjacency-list)
|
|
|
172 ))
|
|
|
173
|
|
|
174 (defvar decipher-mode-syntax-table nil
|
|
|
175 "Decipher mode syntax table")
|
|
|
176
|
|
|
177 (if decipher-mode-syntax-table
|
|
|
178 ()
|
|
|
179 (let ((table (make-syntax-table))
|
|
|
180 (c ?0))
|
|
|
181 (while (<= c ?9)
|
|
|
182 (modify-syntax-entry c "_" table) ;Digits are not part of words
|
|
|
183 (incf c))
|
|
|
184 (setq decipher-mode-syntax-table table)))
|
|
|
185
|
|
|
186 (defvar decipher-alphabet nil)
|
|
|
187 ;; This is an alist containing entries (PLAIN-CHAR . CIPHER-CHAR),
|
|
|
188 ;; where PLAIN-CHAR runs from ?a to ?z and CIPHER-CHAR is an uppercase
|
|
|
189 ;; letter or space (which means no mapping is known for that letter).
|
|
|
190 ;; This *must* contain entries for all lowercase characters.
|
|
|
191 (make-variable-buffer-local 'decipher-alphabet)
|
|
|
192
|
|
|
193 (defvar decipher-stats-buffer nil
|
|
|
194 "The buffer which displays statistics for this ciphertext.
|
|
|
195 Do not access this variable directly, use the function
|
|
|
196 `decipher-stats-buffer' instead.")
|
|
|
197 (make-variable-buffer-local 'decipher-stats-buffer)
|
|
|
198
|
|
|
199 (defvar decipher-undo-list-size 0
|
|
|
200 "The number of entries in the undo list.")
|
|
|
201 (make-variable-buffer-local 'decipher-undo-list-size)
|
|
|
202
|
|
|
203 (defvar decipher-undo-list nil
|
|
|
204 "The undo list for this buffer.
|
|
|
205 Each element is either a cons cell (PLAIN-CHAR . CIPHER-CHAR) or a
|
|
|
206 list of such cons cells.")
|
|
|
207 (make-variable-buffer-local 'decipher-undo-list)
|
|
|
208
|
|
|
209 (defvar decipher-pending-undo-list nil)
|
|
|
210
|
|
|
211 ;; The following variables are used by the analysis functions
|
|
|
212 ;; and are defined here to avoid byte-compiler warnings.
|
|
|
213 ;; Don't mess with them unless you know what you're doing.
|
|
|
214 (defvar decipher-char nil
|
|
|
215 "See the functions decipher-loop-with-breaks and decipher-loop-no-breaks.")
|
|
|
216 (defvar decipher--prev-char)
|
|
|
217 (defvar decipher--digram)
|
|
|
218 (defvar decipher--digram-list)
|
|
|
219 (defvar decipher--before)
|
|
|
220 (defvar decipher--after)
|
|
|
221 (defvar decipher--freqs)
|
|
|
222
|
|
|
223 ;;;===================================================================
|
|
|
224 ;;; Code:
|
|
|
225 ;;;===================================================================
|
|
|
226 ;; Main entry points:
|
|
|
227 ;;--------------------------------------------------------------------
|
|
|
228
|
|
|
229 ;;;###autoload
|
|
|
230 (defun decipher ()
|
|
|
231 "Format a buffer of ciphertext for cryptanalysis and enter Decipher mode."
|
|
|
232 (interactive)
|
|
|
233 ;; Make sure the buffer ends in a newline:
|
|
|
234 (goto-char (point-max))
|
|
|
235 (or (bolp)
|
|
|
236 (insert "\n"))
|
|
|
237 ;; See if it's already in decipher format:
|
|
|
238 (goto-char (point-min))
|
|
|
239 (if (looking-at "^(abcdefghijklmnopqrstuvwxyz \
|
|
|
240 ABCDEFGHIJKLMNOPQRSTUVWXYZ -\\*-decipher-\\*-\n)")
|
|
|
241 (message "Buffer is already formatted, entering Decipher mode...")
|
|
|
242 ;; Add the alphabet at the beginning of the file
|
|
|
243 (insert "(abcdefghijklmnopqrstuvwxyz \
|
|
|
244 ABCDEFGHIJKLMNOPQRSTUVWXYZ -*-decipher-*-\n)\n\n")
|
|
|
245 ;; Add lines for the solution:
|
|
|
246 (let (begin)
|
|
|
247 (while (not (eobp))
|
|
|
248 (if (looking-at "^%")
|
|
|
249 (forward-line) ;Leave comments alone
|
|
|
250 (delete-horizontal-space)
|
|
|
251 (if (eolp)
|
|
|
252 (forward-line) ;Just leave blank lines alone
|
|
|
253 (insert ":") ;Mark ciphertext line
|
|
|
254 (setq begin (point))
|
|
|
255 (forward-line)
|
|
|
256 (if decipher-force-uppercase
|
|
|
257 (upcase-region begin (point))) ;Convert ciphertext to uppercase
|
|
|
258 (insert ">\n"))))) ;Mark plaintext line
|
|
|
259 (delete-blank-lines) ;Remove any blank lines
|
|
|
260 (delete-blank-lines)) ; at end of buffer
|
|
|
261 (goto-line 4)
|
|
|
262 (decipher-mode))
|
|
|
263
|
|
|
264 ;;;###autoload
|
|
|
265 (defun decipher-mode ()
|
|
|
266 "Major mode for decrypting monoalphabetic substitution ciphers.
|
|
|
267 Lower-case letters enter plaintext.
|
|
|
268 Upper-case letters are commands.
|
|
|
269
|
|
|
270 The buffer is made read-only so that normal Emacs commands cannot
|
|
|
271 modify it.
|
|
|
272
|
|
|
273 The most useful commands are:
|
|
|
274 \\<decipher-mode-map>
|
|
|
275 \\[decipher-digram-list] Display a list of all digrams & their frequency
|
|
|
276 \\[decipher-frequency-count] Display the frequency of each ciphertext letter
|
|
|
277 \\[decipher-adjacency-list]\
|
|
|
278 Show adjacency list for current letter (lists letters appearing next to it)
|
|
|
279 \\[decipher-make-checkpoint] Save the current cipher alphabet (checkpoint)
|
|
|
280 \\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)"
|
|
|
281 (interactive)
|
|
|
282 (kill-all-local-variables)
|
|
|
283 (setq buffer-undo-list t ;Disable undo
|
|
|
284 indent-tabs-mode nil ;Do not use tab characters
|
|
|
285 major-mode 'decipher-mode
|
|
|
286 mode-name "Decipher")
|
|
|
287 (if decipher-force-uppercase
|
|
|
288 (setq case-fold-search nil)) ;Case is significant when searching
|
|
|
289 (use-local-map decipher-mode-map)
|
|
|
290 (set-syntax-table decipher-mode-syntax-table)
|
|
|
291 (decipher-read-alphabet)
|
|
|
292 (set (make-local-variable 'font-lock-defaults)
|
|
|
293 '(decipher-font-lock-keywords t))
|
|
|
294 ;; Make the buffer writable when we exit Decipher mode:
|
|
|
295 (make-local-hook 'change-major-mode-hook)
|
|
|
296 (add-hook 'change-major-mode-hook
|
|
|
297 (lambda () (setq buffer-read-only nil
|
|
|
298 buffer-undo-list nil))
|
|
|
299 nil t)
|
|
|
300 (run-hooks 'decipher-mode-hook)
|
|
|
301 (setq buffer-read-only t))
|
|
|
302 (put 'decipher-mode 'mode-class 'special)
|
|
|
303
|
|
|
304 ;;--------------------------------------------------------------------
|
|
|
305 ;; Normal key handling:
|
|
|
306 ;;--------------------------------------------------------------------
|
|
|
307
|
|
|
308 (defmacro decipher-last-command-char ()
|
|
|
309 ;; Return the char which ran this command (for compatibility with XEmacs)
|
|
|
310 (if (fboundp 'event-to-character)
|
|
|
311 '(event-to-character last-command-event)
|
|
|
312 'last-command-event))
|
|
|
313
|
|
|
314 (defun decipher-keypress ()
|
|
|
315 "Enter a plaintext or ciphertext character."
|
|
|
316 (interactive)
|
|
|
317 (let ((decipher-function 'decipher-set-map)
|
|
|
318 buffer-read-only) ;Make buffer writable
|
|
|
319 (save-excursion
|
|
|
320 (or (save-excursion
|
|
|
321 (beginning-of-line)
|
|
|
322 (let ((first-char (following-char)))
|
|
|
323 (cond
|
|
|
324 ((= ?: first-char)
|
|
|
325 t)
|
|
|
326 ((= ?> first-char)
|
|
|
327 nil)
|
|
|
328 ((= ?\( first-char)
|
|
|
329 (setq decipher-function 'decipher-alphabet-keypress)
|
|
|
330 t)
|
|
|
331 ((= ?\) first-char)
|
|
|
332 (setq decipher-function 'decipher-alphabet-keypress)
|
|
|
333 nil)
|
|
|
334 (t
|
|
|
335 (error "Bad location")))))
|
|
|
336 (let (goal-column)
|
|
|
337 (previous-line 1)))
|
|
|
338 (let ((char-a (following-char))
|
|
|
339 (char-b (decipher-last-command-char)))
|
|
|
340 (or (and (not (= ?w (char-syntax char-a)))
|
|
|
341 (= char-b ?\ )) ;Spacebar just advances on non-letters
|
|
|
342 (funcall decipher-function char-a char-b)))))
|
|
|
343 (forward-char))
|
|
|
344
|
|
|
345 (defun decipher-alphabet-keypress (a b)
|
|
|
346 ;; Handle keypresses in the alphabet lines.
|
|
|
347 ;; A is the character in the alphabet row (which starts with '(')
|
|
|
348 ;; B is the character pressed
|
|
|
349 (cond ((and (>= a ?A) (<= a ?Z))
|
|
|
350 ;; If A is uppercase, then it is in the ciphertext alphabet:
|
|
|
351 (decipher-set-map a b))
|
|
|
352 ((and (>= a ?a) (<= a ?z))
|
|
|
353 ;; If A is lowercase, then it is in the plaintext alphabet:
|
|
|
354 (if (= b ?\ )
|
|
|
355 ;; We are clearing the association (if any):
|
|
|
356 (if (/= ?\ (setq b (cdr (assoc a decipher-alphabet))))
|
|
|
357 (decipher-set-map b ?\ ))
|
|
|
358 ;; Associate the plaintext char with the char pressed:
|
|
|
359 (decipher-set-map b a)))
|
|
|
360 (t
|
|
|
361 ;; If A is not a letter, that's a problem:
|
|
|
362 (error "Bad character"))))
|
|
|
363
|
|
|
364 ;;--------------------------------------------------------------------
|
|
|
365 ;; Undo:
|
|
|
366 ;;--------------------------------------------------------------------
|
|
|
367
|
|
|
368 (defun decipher-undo ()
|
|
|
369 "Undo a change in Decipher mode."
|
|
|
370 (interactive)
|
|
|
371 ;; If we don't get all the way thru, make last-command indicate that
|
|
|
372 ;; for the following command.
|
|
|
373 (setq this-command t)
|
|
|
374 (or (eq major-mode 'decipher-mode)
|
|
|
375 (error "This buffer is not in Decipher mode"))
|
|
|
376 (or (eq last-command 'decipher-undo)
|
|
|
377 (setq decipher-pending-undo-list decipher-undo-list))
|
|
|
378 (or decipher-pending-undo-list
|
|
|
379 (error "No further undo information"))
|
|
|
380 (let ((undo-rec (pop decipher-pending-undo-list))
|
|
|
381 buffer-read-only ;Make buffer writable
|
|
|
382 redo-map redo-rec undo-map)
|
|
|
383 (or (consp (car undo-rec))
|
|
|
384 (setq undo-rec (list undo-rec)))
|
|
|
385 (while (setq undo-map (pop undo-rec))
|
|
|
386 (setq redo-map (decipher-get-undo (cdr undo-map) (car undo-map)))
|
|
|
387 (if redo-map
|
|
|
388 (setq redo-rec
|
|
|
389 (if (consp (car redo-map))
|
|
|
390 (append redo-map redo-rec)
|
|
|
391 (cons redo-map redo-rec))))
|
|
|
392 (decipher-set-map (cdr undo-map) (car undo-map) t))
|
|
|
393 (decipher-add-undo redo-rec))
|
|
|
394 (setq this-command 'decipher-undo)
|
|
|
395 (message "Undo!"))
|
|
|
396
|
|
|
397 (defun decipher-add-undo (undo-rec)
|
|
|
398 "Add UNDO-REC to the undo list."
|
|
|
399 (if undo-rec
|
|
|
400 (progn
|
|
|
401 (push undo-rec decipher-undo-list)
|
|
|
402 (incf decipher-undo-list-size)
|
|
|
403 (if (> decipher-undo-list-size decipher-undo-limit)
|
|
|
404 (let ((new-size (- decipher-undo-limit 100)))
|
|
|
405 ;; Truncate undo list to NEW-SIZE elements:
|
|
|
406 (setcdr (nthcdr (1- new-size) decipher-undo-list) nil)
|
|
|
407 (setq decipher-undo-list-size new-size))))))
|
|
|
408
|
|
|
409 (defun decipher-get-undo (cipher-char plain-char)
|
|
|
410 ;; Return an undo record that will undo the result of
|
|
|
411 ;; (decipher-set-map CIPHER-CHAR PLAIN-CHAR)
|
|
|
412 ;; We must use copy-list because the original cons cells will be
|
|
|
413 ;; modified using setcdr.
|
|
|
414 (let ((cipher-map (copy-list (rassoc cipher-char decipher-alphabet)))
|
|
|
415 (plain-map (copy-list (assoc plain-char decipher-alphabet))))
|
|
|
416 (cond ((equal ?\ plain-char)
|
|
|
417 cipher-map)
|
|
|
418 ((equal cipher-char (cdr plain-map))
|
|
|
419 nil) ;We aren't changing anything
|
|
|
420 ((equal ?\ (cdr plain-map))
|
|
|
421 (or cipher-map (cons ?\ cipher-char)))
|
|
|
422 (cipher-map
|
|
|
423 (list plain-map cipher-map))
|
|
|
424 (t
|
|
|
425 plain-map))))
|
|
|
426
|
|
|
427 ;;--------------------------------------------------------------------
|
|
|
428 ;; Mapping ciphertext and plaintext:
|
|
|
429 ;;--------------------------------------------------------------------
|
|
|
430
|
|
|
431 (defun decipher-set-map (cipher-char plain-char &optional no-undo)
|
|
|
432 ;; Associate a ciphertext letter with a plaintext letter
|
|
|
433 ;; CIPHER-CHAR must be an uppercase or lowercase letter
|
|
|
434 ;; PLAIN-CHAR must be a lowercase letter (or a space)
|
|
|
435 ;; NO-UNDO if non-nil means do not record undo information
|
|
|
436 ;; Any existing associations for CIPHER-CHAR or PLAIN-CHAR will be erased.
|
|
|
437 (setq cipher-char (upcase cipher-char))
|
|
|
438 (or (and (>= cipher-char ?A) (<= cipher-char ?Z))
|
|
|
439 (error "Bad character")) ;Cipher char must be uppercase letter
|
|
|
440 (or no-undo
|
|
|
441 (decipher-add-undo (decipher-get-undo cipher-char plain-char)))
|
|
|
442 (let ((cipher-string (char-to-string cipher-char))
|
|
|
443 (plain-string (char-to-string plain-char))
|
|
|
444 case-fold-search ;Case is significant
|
|
|
445 mapping bound)
|
|
|
446 (save-excursion
|
|
|
447 (goto-char (point-min))
|
|
|
448 (if (setq mapping (rassoc cipher-char decipher-alphabet))
|
|
|
449 (progn
|
|
|
450 (setcdr mapping ?\ )
|
|
|
451 (search-forward-regexp (concat "^([a-z]*"
|
|
|
452 (char-to-string (car mapping))))
|
|
|
453 (decipher-insert ?\ )
|
|
|
454 (beginning-of-line)))
|
|
|
455 (if (setq mapping (assoc plain-char decipher-alphabet))
|
|
|
456 (progn
|
|
|
457 (if (/= ?\ (cdr mapping))
|
|
|
458 (decipher-set-map (cdr mapping) ?\ t))
|
|
|
459 (setcdr mapping cipher-char)
|
|
|
460 (search-forward-regexp (concat "^([a-z]*" plain-string))
|
|
|
461 (decipher-insert cipher-char)
|
|
|
462 (beginning-of-line)))
|
|
|
463 (search-forward-regexp (concat "^([a-z]+ [A-Z]*" cipher-string))
|
|
|
464 (decipher-insert plain-char)
|
|
|
465 (setq case-fold-search t ;Case is not significant
|
|
|
466 cipher-string (downcase cipher-string))
|
|
|
467 (let ((font-lock-fontify-region-function 'ignore))
|
|
|
468 ;; insert-and-inherit will pick the right face automatically
|
|
|
469 (while (search-forward-regexp "^:" nil t)
|
|
|
470 (setq bound (save-excursion (end-of-line) (point)))
|
|
|
471 (while (search-forward cipher-string bound 'end)
|
|
|
472 (decipher-insert plain-char)))))))
|
|
|
473
|
|
|
474 (defun decipher-insert (char)
|
|
|
475 ;; Insert CHAR in the row below point. It replaces any existing
|
|
|
476 ;; character in that position.
|
|
|
477 (let ((col (1- (current-column))))
|
|
|
478 (save-excursion
|
|
|
479 (forward-line)
|
|
|
480 (or (= ?\> (following-char))
|
|
|
481 (= ?\) (following-char))
|
|
|
482 (error "Bad location"))
|
|
|
483 (move-to-column col t)
|
|
|
484 (or (eolp)
|
|
|
485 (delete-char 1))
|
|
|
486 (insert-and-inherit char))))
|
|
|
487
|
|
|
488 ;;--------------------------------------------------------------------
|
|
|
489 ;; Checkpoints:
|
|
|
490 ;;--------------------------------------------------------------------
|
|
|
491 ;; A checkpoint is a comment of the form:
|
|
|
492 ;; %!ABCDEFGHIJKLMNOPQRSTUVWXYZ! Description
|
|
|
493 ;; Such comments are usually placed at the end of the buffer following
|
|
|
494 ;; this header (which is inserted by decipher-make-checkpoint):
|
|
|
495 ;; %---------------------------
|
|
|
496 ;; % Checkpoints:
|
|
|
497 ;; % abcdefghijklmnopqrstuvwxyz
|
|
|
498 ;; but this is not required; checkpoints can be placed anywhere.
|
|
|
499 ;;
|
|
|
500 ;; The description is optional; all that is required is the alphabet.
|
|
|
501
|
|
|
502 (defun decipher-make-checkpoint (desc)
|
|
|
503 "Checkpoint the current cipher alphabet.
|
|
|
504 This records the current alphabet so you can return to it later.
|
|
|
505 You may have any number of checkpoints.
|
|
|
506 Type `\\[decipher-restore-checkpoint]' to restore a checkpoint."
|
|
|
507 (interactive "sCheckpoint description: ")
|
|
|
508 (or (stringp desc)
|
|
|
509 (setq desc ""))
|
|
|
510 (let (alphabet
|
|
|
511 buffer-read-only ;Make buffer writable
|
|
|
512 mapping)
|
|
|
513 (goto-char (point-min))
|
|
|
514 (re-search-forward "^)")
|
|
|
515 (move-to-column 27 t)
|
|
|
516 (setq alphabet (buffer-substring-no-properties (- (point) 26) (point)))
|
|
|
517 (if (re-search-forward "^%![A-Z ]+!" nil 'end)
|
|
|
518 nil ; Add new checkpoint with others
|
|
|
519 (if (re-search-backward "^% *Local Variables:" nil t)
|
|
|
520 ;; Add checkpoints before local variables list:
|
|
|
521 (progn (forward-line -1)
|
|
|
522 (or (looking-at "^ *$")
|
|
|
523 (progn (forward-line) (insert ?\n) (forward-line -1)))))
|
|
|
524 (insert "\n%" (make-string 69 ?\-)
|
|
|
525 "\n% Checkpoints:\n% abcdefghijklmnopqrstuvwxyz\n"))
|
|
|
526 (beginning-of-line)
|
|
|
527 (insert "%!" alphabet "! " desc ?\n)))
|
|
|
528
|
|
|
529 (defun decipher-restore-checkpoint ()
|
|
|
530 "Restore the cipher alphabet from a checkpoint.
|
|
|
531 If point is not on a checkpoint line, moves to the first checkpoint line.
|
|
|
532 If point is on a checkpoint, restores that checkpoint.
|
|
|
533
|
|
|
534 Type `\\[decipher-make-checkpoint]' to make a checkpoint."
|
|
|
535 (interactive)
|
|
|
536 (beginning-of-line)
|
|
|
537 (if (looking-at "%!\\([A-Z ]+\\)!")
|
|
|
538 ;; Restore this checkpoint:
|
|
|
539 (let ((alphabet (match-string 1))
|
|
|
540 buffer-read-only) ;Make buffer writable
|
|
|
541 (goto-char (point-min))
|
|
|
542 (re-search-forward "^)")
|
|
|
543 (or (eolp)
|
|
|
544 (delete-region (point) (progn (end-of-line) (point))))
|
|
|
545 (insert alphabet)
|
|
|
546 (decipher-resync))
|
|
|
547 ;; Move to the first checkpoint:
|
|
|
548 (goto-char (point-min))
|
|
|
549 (if (re-search-forward "^%![A-Z ]+!" nil t)
|
|
|
550 (message "Select the checkpoint to restore and type `%s'"
|
|
|
551 (substitute-command-keys "\\[decipher-restore-checkpoint]"))
|
|
|
552 (error "No checkpoints in this buffer"))))
|
|
|
553
|
|
|
554 ;;--------------------------------------------------------------------
|
|
|
555 ;; Miscellaneous commands:
|
|
|
556 ;;--------------------------------------------------------------------
|
|
|
557
|
|
|
558 (defun decipher-complete-alphabet ()
|
|
|
559 "Complete the cipher alphabet.
|
|
|
560 This fills any blanks in the cipher alphabet with the unused letters
|
|
|
561 in alphabetical order. Use this when you have a keyword cipher and
|
|
|
562 you have determined the keyword."
|
|
|
563 (interactive)
|
|
|
564 (let ((cipher-char ?A)
|
|
|
565 (ptr decipher-alphabet)
|
|
|
566 buffer-read-only ;Make buffer writable
|
|
|
567 plain-map undo-rec)
|
|
|
568 (while (setq plain-map (pop ptr))
|
|
|
569 (if (equal ?\ (cdr plain-map))
|
|
|
570 (progn
|
|
|
571 (while (rassoc cipher-char decipher-alphabet)
|
|
|
572 ;; Find the next unused letter
|
|
|
573 (incf cipher-char))
|
|
|
574 (push (cons ?\ cipher-char) undo-rec)
|
|
|
575 (decipher-set-map cipher-char (car plain-map) t))))
|
|
|
576 (decipher-add-undo undo-rec)))
|
|
|
577
|
|
|
578 (defun decipher-show-alphabet ()
|
|
|
579 "Display the current cipher alphabet in the message line."
|
|
|
580 (interactive)
|
|
|
581 (message
|
|
|
582 (mapconcat (lambda (a)
|
|
|
583 (concat
|
|
|
584 (char-to-string (car a))
|
|
|
585 (char-to-string (cdr a))))
|
|
|
586 decipher-alphabet
|
|
|
587 "")))
|
|
|
588
|
|
|
589 (defun decipher-resync ()
|
|
|
590 "Reprocess the buffer using the alphabet from the top.
|
|
|
591 This regenerates all deciphered plaintext and clears the undo list.
|
|
|
592 You should use this if you edit the ciphertext."
|
|
|
593 (interactive)
|
|
|
594 (message "Reprocessing buffer...")
|
|
|
595 (let (alphabet
|
|
|
596 buffer-read-only ;Make buffer writable
|
|
|
597 mapping)
|
|
|
598 (save-excursion
|
|
|
599 (decipher-read-alphabet)
|
|
|
600 (setq alphabet decipher-alphabet)
|
|
|
601 (goto-char (point-min))
|
|
|
602 (and (re-search-forward "^).+" nil t)
|
|
|
603 (replace-match ")" nil nil))
|
|
|
604 (while (re-search-forward "^>.+" nil t)
|
|
|
605 (replace-match ">" nil nil))
|
|
|
606 (decipher-read-alphabet)
|
|
|
607 (while (setq mapping (pop alphabet))
|
|
|
608 (or (equal ?\ (cdr mapping))
|
|
|
609 (decipher-set-map (cdr mapping) (car mapping))))))
|
|
|
610 (setq decipher-undo-list nil
|
|
|
611 decipher-undo-list-size 0)
|
|
|
612 (message "Reprocessing buffer...done"))
|
|
|
613
|
|
|
614 ;;--------------------------------------------------------------------
|
|
|
615 ;; Miscellaneous functions:
|
|
|
616 ;;--------------------------------------------------------------------
|
|
|
617
|
|
|
618 (defun decipher-read-alphabet ()
|
|
|
619 "Build the decipher-alphabet from the alphabet line in the buffer."
|
|
|
620 (save-excursion
|
|
|
621 (goto-char (point-min))
|
|
|
622 (search-forward-regexp "^)")
|
|
|
623 (move-to-column 27 t)
|
|
|
624 (setq decipher-alphabet nil)
|
|
|
625 (let ((plain-char ?z))
|
|
|
626 (while (>= plain-char ?a)
|
|
|
627 (backward-char)
|
|
|
628 (push (cons plain-char (following-char)) decipher-alphabet)
|
|
|
629 (decf plain-char)))))
|
|
|
630
|
|
|
631 ;;;===================================================================
|
|
|
632 ;;; Analyzing ciphertext:
|
|
|
633 ;;;===================================================================
|
|
|
634
|
|
|
635 (defun decipher-frequency-count ()
|
|
|
636 "Display the frequency count in the statistics buffer."
|
|
|
637 (interactive)
|
|
|
638 (decipher-analyze)
|
|
|
639 (decipher-display-regexp "^A" "^[A-Z][A-Z]"))
|
|
|
640
|
|
|
641 (defun decipher-digram-list ()
|
|
|
642 "Display the list of digrams in the statistics buffer."
|
|
|
643 (interactive)
|
|
|
644 (decipher-analyze)
|
|
|
645 (decipher-display-regexp "[A-Z][A-Z] +[0-9]" "^$"))
|
|
|
646
|
|
|
647 (defun decipher-adjacency-list (cipher-char)
|
|
|
648 "Display the adjacency list for the letter at point.
|
|
|
649 The adjacency list shows all letters which come next to CIPHER-CHAR.
|
|
|
650
|
|
|
651 An adjacency list (for the letter X) looks like this:
|
|
|
652 1 1 1 1 1 3 2 1 3 8
|
|
|
653 X: A B C D E F G H I J K L M N O P Q R S T U V W X Y Z * 11 14 9%
|
|
|
654 1 1 1 2 1 1 2 5 7
|
|
|
655 This says that X comes before D once, and after B once. X begins 5
|
|
|
656 words, and ends 3 words (`*' represents a space). X comes before 8
|
|
|
657 different letters, after 7 differerent letters, and is next to a total
|
|
|
658 of 11 different letters. It occurs 14 times, making up 9% of the
|
|
|
659 ciphertext."
|
|
|
660 (interactive (list (upcase (following-char))))
|
|
|
661 (decipher-analyze)
|
|
|
662 (let (start end)
|
|
|
663 (save-excursion
|
|
|
664 (set-buffer (decipher-stats-buffer))
|
|
|
665 (goto-char (point-min))
|
|
|
666 (or (re-search-forward (format "^%c: " cipher-char) nil t)
|
|
|
667 (error "Character `%c' is not used in ciphertext." cipher-char))
|
|
|
668 (forward-line -1)
|
|
|
669 (setq start (point))
|
|
|
670 (forward-line 3)
|
|
|
671 (setq end (point)))
|
|
|
672 (decipher-display-range start end)))
|
|
|
673
|
|
|
674 ;;--------------------------------------------------------------------
|
|
|
675 (defun decipher-analyze ()
|
|
|
676 "Perform frequency analysis on the current buffer if necessary."
|
|
|
677 (cond
|
|
|
678 ;; If this is the statistics buffer, do nothing:
|
|
|
679 ((eq major-mode 'decipher-stats-mode))
|
|
|
680 ;; If this is the Decipher buffer, see if the stats buffer exists:
|
|
|
681 ((eq major-mode 'decipher-mode)
|
|
|
682 (or (and (bufferp decipher-stats-buffer)
|
|
|
683 (buffer-name decipher-stats-buffer))
|
|
|
684 (decipher-analyze-buffer)))
|
|
|
685 ;; Otherwise:
|
|
|
686 (t (error "This buffer is not in Decipher mode"))))
|
|
|
687
|
|
|
688 ;;--------------------------------------------------------------------
|
|
|
689 (defun decipher-display-range (start end)
|
|
|
690 "Display text between START and END in the statistics buffer.
|
|
|
691 START and END are positions in the statistics buffer. Makes the
|
|
|
692 statistics buffer visible and sizes the window to just fit the
|
|
|
693 displayed text, but leaves the current window selected."
|
|
|
694 (let ((stats-buffer (decipher-stats-buffer))
|
|
|
695 (current-window (selected-window))
|
|
|
696 (pop-up-windows t))
|
|
|
697 (or (eq (current-buffer) stats-buffer)
|
|
|
698 (pop-to-buffer stats-buffer))
|
|
|
699 (goto-char start)
|
|
|
700 (or (one-window-p t)
|
|
|
701 (enlarge-window (- (1+ (count-lines start end)) (window-height))))
|
|
|
702 (recenter 0)
|
|
|
703 (select-window current-window)))
|
|
|
704
|
|
|
705 (defun decipher-display-regexp (start-regexp end-regexp)
|
|
|
706 "Display text between two regexps in the statistics buffer.
|
|
|
707
|
|
|
708 START-REGEXP matches the first line to display.
|
|
|
709 END-REGEXP matches the line after that which ends the display.
|
|
|
710 The ending line is included in the display unless it is blank."
|
|
|
711 (let (start end)
|
|
|
712 (save-excursion
|
|
|
713 (set-buffer (decipher-stats-buffer))
|
|
|
714 (goto-char (point-min))
|
|
|
715 (re-search-forward start-regexp)
|
|
|
716 (beginning-of-line)
|
|
|
717 (setq start (point))
|
|
|
718 (re-search-forward end-regexp)
|
|
|
719 (beginning-of-line)
|
|
|
720 (or (looking-at "^ *$")
|
|
|
721 (forward-line 1))
|
|
|
722 (setq end (point)))
|
|
|
723 (decipher-display-range start end)))
|
|
|
724
|
|
|
725 ;;--------------------------------------------------------------------
|
|
|
726 (defun decipher-loop-with-breaks (func)
|
|
|
727 "Loop through ciphertext, calling FUNC once for each letter & word division.
|
|
|
728
|
|
|
729 FUNC is called with no arguments, and its return value is unimportant.
|
|
|
730 It may examine `decipher-char' to see the current ciphertext
|
|
|
731 character. `decipher-char' contains either an uppercase letter or a space.
|
|
|
732
|
|
|
733 FUNC is called exactly once between words, with `decipher-char' set to
|
|
|
734 a space.
|
|
|
735
|
|
|
736 See `decipher-loop-no-breaks' if you do not care about word divisions."
|
|
|
737 (let ((decipher-char ?\ )
|
|
|
738 (decipher--loop-prev-char ?\ ))
|
|
|
739 (save-excursion
|
|
|
740 (goto-char (point-min))
|
|
|
741 (funcall func) ;Space marks beginning of first word
|
|
|
742 (while (search-forward-regexp "^:" nil t)
|
|
|
743 (while (not (eolp))
|
|
|
744 (setq decipher-char (upcase (following-char)))
|
|
|
745 (or (and (>= decipher-char ?A) (<= decipher-char ?Z))
|
|
|
746 (setq decipher-char ?\ ))
|
|
|
747 (or (and (equal decipher-char ?\ )
|
|
|
748 (equal decipher--loop-prev-char ?\ ))
|
|
|
749 (funcall func))
|
|
|
750 (setq decipher--loop-prev-char decipher-char)
|
|
|
751 (forward-char))
|
|
|
752 (or (equal decipher-char ?\ )
|
|
|
753 (progn
|
|
|
754 (setq decipher-char ?\ ;
|
|
|
755 decipher--loop-prev-char ?\ )
|
|
|
756 (funcall func)))))))
|
|
|
757
|
|
|
758 (defun decipher-loop-no-breaks (func)
|
|
|
759 "Loop through ciphertext, calling FUNC once for each letter.
|
|
|
760
|
|
|
761 FUNC is called with no arguments, and its return value is unimportant.
|
|
|
762 It may examine `decipher-char' to see the current ciphertext letter.
|
|
|
763 `decipher-char' contains an uppercase letter.
|
|
|
764
|
|
|
765 Punctuation and spacing in the ciphertext are ignored.
|
|
|
766 See `decipher-loop-with-breaks' if you care about word divisions."
|
|
|
767 (let (decipher-char)
|
|
|
768 (save-excursion
|
|
|
769 (goto-char (point-min))
|
|
|
770 (while (search-forward-regexp "^:" nil t)
|
|
|
771 (while (not (eolp))
|
|
|
772 (setq decipher-char (upcase (following-char)))
|
|
|
773 (and (>= decipher-char ?A)
|
|
|
774 (<= decipher-char ?Z)
|
|
|
775 (funcall func))
|
|
|
776 (forward-char))))))
|
|
|
777
|
|
|
778 ;;--------------------------------------------------------------------
|
|
|
779 ;; Perform the analysis:
|
|
|
780 ;;--------------------------------------------------------------------
|
|
|
781
|
|
|
782 (defun decipher-insert-frequency-counts (freq-list total)
|
|
|
783 "Insert frequency counts in current buffer.
|
|
|
784 Each element of FREQ-LIST is a list (LETTER FREQ ...).
|
|
|
785 TOTAL is the total number of letters in the ciphertext."
|
|
|
786 (let ((i 4) temp-list)
|
|
|
787 (while (> i 0)
|
|
|
788 (setq temp-list freq-list)
|
|
|
789 (while temp-list
|
|
|
790 (insert (caar temp-list)
|
|
|
791 (format "%4d%3d%% "
|
|
|
792 (cadar temp-list)
|
|
|
793 (/ (* 100 (cadar temp-list)) total)))
|
|
|
794 (setq temp-list (nthcdr 4 temp-list)))
|
|
|
795 (insert ?\n)
|
|
|
796 (setq freq-list (cdr freq-list)
|
|
|
797 i (1- i)))))
|
|
|
798
|
|
|
799 (defun decipher--analyze ()
|
|
|
800 ;; Perform frequency analysis on ciphertext.
|
|
|
801 ;;
|
|
|
802 ;; This function is called repeatedly with decipher-char set to each
|
|
|
803 ;; character of ciphertext. It uses decipher--prev-char to remember
|
|
|
804 ;; the previous ciphertext character.
|
|
|
805 ;;
|
|
|
806 ;; It builds several data structures, which must be initialized
|
|
|
807 ;; before the first call to decipher--analyze. The arrays are
|
|
|
808 ;; indexed with A = 0, B = 1, ..., Z = 25, SPC = 26 (if used).
|
|
|
809 ;; decipher--after: (initialize to zeros)
|
|
|
810 ;; A vector of 26 vectors of 27 integers. The first vector
|
|
|
811 ;; represents the number of times A follows each character, the
|
|
|
812 ;; second vector represents B, and so on.
|
|
|
813 ;; decipher--before: (initialize to zeros)
|
|
|
814 ;; The same as decipher--after, but representing the number of
|
|
|
815 ;; times the character precedes each other character.
|
|
|
816 ;; decipher--digram-list: (initialize to nil)
|
|
|
817 ;; An alist with an entry for each digram (2-character sequence)
|
|
|
818 ;; encountered. Each element is a cons cell (DIGRAM . FREQ),
|
|
|
819 ;; where DIGRAM is a 2 character string and FREQ is the number
|
|
|
820 ;; of times it occurs.
|
|
|
821 ;; decipher--freqs: (initialize to zeros)
|
|
|
822 ;; A vector of 26 integers, counting the number of occurrences
|
|
|
823 ;; of the corresponding characters.
|
|
|
824 (setq decipher--digram (format "%c%c" decipher--prev-char decipher-char))
|
|
|
825 (incf (cdr (or (assoc decipher--digram decipher--digram-list)
|
|
|
826 (car (push (cons decipher--digram 0)
|
|
|
827 decipher--digram-list)))))
|
|
|
828 (and (>= decipher--prev-char ?A)
|
|
|
829 (incf (aref (aref decipher--before (- decipher--prev-char ?A))
|
|
|
830 (if (equal decipher-char ?\ )
|
|
|
831 26
|
|
|
832 (- decipher-char ?A)))))
|
|
|
833 (and (>= decipher-char ?A)
|
|
|
834 (incf (aref decipher--freqs (- decipher-char ?A)))
|
|
|
835 (incf (aref (aref decipher--after (- decipher-char ?A))
|
|
|
836 (if (equal decipher--prev-char ?\ )
|
|
|
837 26
|
|
|
838 (- decipher--prev-char ?A)))))
|
|
|
839 (setq decipher--prev-char decipher-char))
|
|
|
840
|
|
|
841 (defun decipher--digram-counts (counts)
|
|
|
842 "Generate the counts for an adjacency list."
|
|
|
843 (let ((total 0))
|
|
|
844 (concat
|
|
|
845 (mapconcat (lambda (x)
|
|
|
846 (cond ((> x 99) (incf total) "XX")
|
|
|
847 ((> x 0) (incf total) (format "%2d" x))
|
|
|
848 (t " ")))
|
|
|
849 counts
|
|
|
850 "")
|
|
|
851 (format "%4d" (if (> (aref counts 26) 0)
|
|
|
852 (1- total) ;Don't count space
|
|
|
853 total)))))
|
|
|
854
|
|
|
855 (defun decipher--digram-total (before-count after-count)
|
|
|
856 "Count the number of different letters a letter appears next to."
|
|
|
857 ;; We do not include spaces (word divisions) in this count.
|
|
|
858 (let ((total 0)
|
|
|
859 (i 26))
|
|
|
860 (while (>= (decf i) 0)
|
|
|
861 (if (or (> (aref before-count i) 0)
|
|
|
862 (> (aref after-count i) 0))
|
|
|
863 (incf total)))
|
|
|
864 total))
|
|
|
865
|
|
|
866 (defun decipher-analyze-buffer ()
|
|
|
867 "Perform frequency analysis and store results in statistics buffer.
|
|
|
868 Creates the statistics buffer if it doesn't exist."
|
|
|
869 (let ((decipher--prev-char (if decipher-ignore-spaces ?\ ?\*))
|
|
|
870 (decipher--before (make-vector 26 nil))
|
|
|
871 (decipher--after (make-vector 26 nil))
|
|
|
872 (decipher--freqs (make-vector 26 0))
|
|
|
873 (total-chars 0)
|
|
|
874 decipher--digram decipher--digram-list freq-list)
|
|
|
875 (message "Scanning buffer...")
|
|
|
876 (let ((i 26))
|
|
|
877 (while (>= (decf i) 0)
|
|
|
878 (aset decipher--before i (make-vector 27 0))
|
|
|
879 (aset decipher--after i (make-vector 27 0))))
|
|
|
880 (if decipher-ignore-spaces
|
|
|
881 (progn
|
|
|
882 (decipher-loop-no-breaks 'decipher--analyze)
|
|
|
883 ;; The first character of ciphertext was marked as following a space:
|
|
|
884 (let ((i 26))
|
|
|
885 (while (>= (decf i) 0)
|
|
|
886 (aset (aref decipher--after i) 26 0))))
|
|
|
887 (decipher-loop-with-breaks 'decipher--analyze))
|
|
|
888 (message "Processing results...")
|
|
|
889 (setcdr (last decipher--digram-list 2) nil) ;Delete the phony "* " digram
|
|
|
890 ;; Sort the digram list by frequency and alphabetical order:
|
|
|
891 (setq decipher--digram-list (sort (sort decipher--digram-list
|
|
|
892 (lambda (a b) (string< (car a) (car b))))
|
|
|
893 (lambda (a b) (> (cdr a) (cdr b)))))
|
|
|
894 ;; Generate the frequency list:
|
|
|
895 ;; Each element is a list of 3 elements (LETTER FREQ DIFFERENT),
|
|
|
896 ;; where LETTER is the ciphertext character, FREQ is the number
|
|
|
897 ;; of times it occurs, and DIFFERENT is the number of different
|
|
|
898 ;; letters it appears next to.
|
|
|
899 (let ((i 26))
|
|
|
900 (while (>= (decf i) 0)
|
|
|
901 (setq freq-list
|
|
|
902 (cons (list (+ i ?A)
|
|
|
903 (aref decipher--freqs i)
|
|
|
904 (decipher--digram-total (aref decipher--before i)
|
|
|
905 (aref decipher--after i)))
|
|
|
906 freq-list)
|
|
|
907 total-chars (+ total-chars (aref decipher--freqs i)))))
|
|
|
908 (save-excursion
|
|
|
909 ;; Switch to statistics buffer, creating it if necessary:
|
|
|
910 (set-buffer (decipher-stats-buffer t))
|
|
|
911 ;; This can't happen, but it never hurts to double-check:
|
|
|
912 (or (eq major-mode 'decipher-stats-mode)
|
|
|
913 (error "Buffer %s is not in Decipher-Stats mode" (buffer-name)))
|
|
|
914 (setq buffer-read-only nil)
|
|
|
915 (erase-buffer)
|
|
|
916 ;; Display frequency counts for letters A-Z:
|
|
|
917 (decipher-insert-frequency-counts freq-list total-chars)
|
|
|
918 (insert ?\n)
|
|
|
919 ;; Display frequency counts for letters in order of frequency:
|
|
|
920 (setq freq-list (sort freq-list
|
|
|
921 (lambda (a b) (> (second a) (second b)))))
|
|
|
922 (decipher-insert-frequency-counts freq-list total-chars)
|
|
|
923 ;; Display letters in order of frequency:
|
|
|
924 (insert ?\n (mapconcat (lambda (a) (char-to-string (car a)))
|
|
|
925 freq-list nil)
|
|
|
926 "\n\n")
|
|
|
927 ;; Display list of digrams in order of frequency:
|
|
|
928 (let* ((rows (floor (+ (length decipher--digram-list) 9) 10))
|
|
|
929 (i rows)
|
|
|
930 temp-list)
|
|
|
931 (while (> i 0)
|
|
|
932 (setq temp-list decipher--digram-list)
|
|
|
933 (while temp-list
|
|
|
934 (insert (caar temp-list)
|
|
|
935 (format "%3d "
|
|
|
936 (cdar temp-list)))
|
|
|
937 (setq temp-list (nthcdr rows temp-list)))
|
|
|
938 (delete-horizontal-space)
|
|
|
939 (insert ?\n)
|
|
|
940 (setq decipher--digram-list (cdr decipher--digram-list)
|
|
|
941 i (1- i))))
|
|
|
942 ;; Display adjacency list for each letter, sorted in descending
|
|
|
943 ;; order of the number of adjacent letters:
|
|
|
944 (setq freq-list (sort freq-list
|
|
|
945 (lambda (a b) (> (third a) (third b)))))
|
|
|
946 (let ((temp-list freq-list)
|
|
|
947 entry i)
|
|
|
948 (while (setq entry (pop temp-list))
|
|
|
949 (if (equal 0 (second entry))
|
|
|
950 nil ;This letter was not used
|
|
|
951 (setq i (- (car entry) ?A))
|
|
|
952 (insert ?\n " "
|
|
|
953 (decipher--digram-counts (aref decipher--before i)) ?\n
|
|
|
954 (car entry)
|
|
|
955 ": A B C D E F G H I J K L M N O P Q R S T U V W X Y Z *"
|
|
|
956 (format "%4d %4d %3d%%\n "
|
|
|
957 (third entry) (second entry)
|
|
|
958 (/ (* 100 (second entry)) total-chars))
|
|
|
959 (decipher--digram-counts (aref decipher--after i)) ?\n))))
|
|
|
960 (setq buffer-read-only t)
|
|
|
961 (set-buffer-modified-p nil)
|
|
|
962 ))
|
|
|
963 (message nil))
|
|
|
964
|
|
|
965 ;;====================================================================
|
|
|
966 ;; Statistics Buffer:
|
|
|
967 ;;====================================================================
|
|
|
968
|
|
|
969 (defun decipher-stats-mode ()
|
|
|
970 "Major mode for displaying ciphertext statistics."
|
|
|
971 (interactive)
|
|
|
972 (kill-all-local-variables)
|
|
|
973 (setq buffer-read-only t
|
|
|
974 buffer-undo-list t ;Disable undo
|
|
|
975 case-fold-search nil ;Case is significant when searching
|
|
|
976 indent-tabs-mode nil ;Do not use tab characters
|
|
|
977 major-mode 'decipher-stats-mode
|
|
|
978 mode-name "Decipher-Stats")
|
|
|
979 (use-local-map decipher-stats-mode-map)
|
|
|
980 (run-hooks 'decipher-stats-mode-hook))
|
|
|
981 (put 'decipher-stats-mode 'mode-class 'special)
|
|
|
982
|
|
|
983 ;;--------------------------------------------------------------------
|
|
|
984
|
|
|
985 (defun decipher-display-stats-buffer ()
|
|
|
986 "Make the statistics buffer visible, but do not select it."
|
|
|
987 (let ((stats-buffer (decipher-stats-buffer))
|
|
|
988 (current-window (selected-window)))
|
|
|
989 (or (eq (current-buffer) stats-buffer)
|
|
|
990 (progn
|
|
|
991 (pop-to-buffer stats-buffer)
|
|
|
992 (select-window current-window)))))
|
|
|
993
|
|
|
994 (defun decipher-stats-buffer (&optional create)
|
|
|
995 "Return the buffer used for decipher statistics.
|
|
|
996 If CREATE is non-nil, create the buffer if it doesn't exist.
|
|
|
997 This is guaranteed to return a buffer in Decipher-Stats mode;
|
|
|
998 if it can't, it signals an error."
|
|
|
999 (cond
|
|
|
1000 ;; We may already be in the statistics buffer:
|
|
|
1001 ((eq major-mode 'decipher-stats-mode)
|
|
|
1002 (current-buffer))
|
|
|
1003 ;; See if decipher-stats-buffer exists:
|
|
|
1004 ((and (bufferp decipher-stats-buffer)
|
|
|
1005 (buffer-name decipher-stats-buffer))
|
|
|
1006 (or (save-excursion
|
|
|
1007 (set-buffer decipher-stats-buffer)
|
|
|
1008 (eq major-mode 'decipher-stats-mode))
|
|
|
1009 (error "Buffer %s is not in Decipher-Stats mode"
|
|
|
1010 (buffer-name decipher-stats-buffer)))
|
|
|
1011 decipher-stats-buffer)
|
|
|
1012 ;; Create a new buffer if requested:
|
|
|
1013 (create
|
|
|
1014 (let ((stats-name (concat "*" (buffer-name) "*")))
|
|
|
1015 (setq decipher-stats-buffer
|
|
|
1016 (if (eq 'decipher-stats-mode
|
|
|
1017 (cdr-safe (assoc 'major-mode
|
|
|
1018 (buffer-local-variables
|
|
|
1019 (get-buffer stats-name)))))
|
|
|
1020 ;; We just lost track of the statistics buffer:
|
|
|
1021 (get-buffer stats-name)
|
|
|
1022 (generate-new-buffer stats-name))))
|
|
|
1023 (save-excursion
|
|
|
1024 (set-buffer decipher-stats-buffer)
|
|
|
1025 (decipher-stats-mode))
|
|
|
1026 decipher-stats-buffer)
|
|
|
1027 ;; Give up:
|
|
|
1028 (t (error "No statistics buffer"))))
|
|
|
1029
|
|
|
1030 ;;====================================================================
|
|
|
1031
|
|
|
1032 (provide 'decipher)
|
|
|
1033
|
|
|
1034 ;;;(defun decipher-show-undo-list ()
|
|
|
1035 ;;; "Display the undo list (for debugging purposes)."
|
|
|
1036 ;;; (interactive)
|
|
|
1037 ;;; (with-output-to-temp-buffer "*Decipher Undo*"
|
|
|
1038 ;;; (let ((undo-list decipher-undo-list)
|
|
|
1039 ;;; undo-rec undo-map)
|
|
|
1040 ;;; (save-excursion
|
|
|
1041 ;;; (set-buffer "*Decipher Undo*")
|
|
|
1042 ;;; (while (setq undo-rec (pop undo-list))
|
|
|
1043 ;;; (or (consp (car undo-rec))
|
|
|
1044 ;;; (setq undo-rec (list undo-rec)))
|
|
|
1045 ;;; (insert ?\()
|
|
|
1046 ;;; (while (setq undo-map (pop undo-rec))
|
|
|
1047 ;;; (insert (cdr undo-map) (car undo-map) ?\ ))
|
|
|
1048 ;;; (delete-backward-char 1)
|
|
|
1049 ;;; (insert ")\n"))))))
|
|
|
1050
|
|
|
1051 ;;; decipher.el ends here
|
