1 ;;; decipher.el --- Cryptanalyze monoalphabetic substitution ciphers
3 ;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
5 ;; Author: Christopher J. Madsen <ac608@yfn.ysu.edu>
8 ;; This file is part of GNU Emacs.
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)
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.
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.
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.
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
36 ;; Cryptanalysis: A study of ciphers and their solution
37 ;; Helen Fouche Gaines
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.)
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)
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.
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)
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.
69 ;; While the cipher message may contain digits or punctuation, Decipher
70 ;; mode will ignore these characters.
72 ;; The buffer is made read-only so it can't be modified by normal
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.
83 ;; Email me if you have any suggestions or would like to help.
84 ;; But be aware that I work on Decipher only sporadically.
86 ;; 1. The consonant-line shortcut
87 ;; 2. More functions for analyzing ciphertext
89 ;;;===================================================================
91 ;;;===================================================================
96 (defgroup decipher nil
97 "Cryptanalyze monoalphabetic substitution ciphers."
101 (defcustom decipher-force-uppercase t
102 "*Non-nil means to convert ciphertext to uppercase.
103 Nil means the case of the ciphertext is preserved.
104 This variable must be set before typing `\\[decipher]'."
109 (defcustom decipher-ignore-spaces nil
110 "*Non-nil means to ignore spaces and punctuation when counting digrams.
111 You should set this to `nil' if the cipher message is divided into words,
113 This variable is buffer-local."
116 (make-variable-buffer-local 'decipher-ignore-spaces
)
118 (defcustom decipher-undo-limit
5000
119 "The maximum number of entries in the undo list.
120 When the undo list exceeds this number, 100 entries are deleted from
121 the tail of the list."
125 (defcustom decipher-mode-hook nil
126 "Hook to run upon entry to decipher."
130 ;; End of user modifiable variables
131 ;;--------------------------------------------------------------------
133 (defvar decipher-font-lock-keywords
134 '(("^:.*" . font-lock-keyword-face
)
135 ("^>.*" . font-lock-string-face
)
136 ("^%!.*" . font-lock-constant-face
)
137 ("^%.*" . font-lock-comment-face
)
138 ("\\`(\\([a-z]+\\) +\\([A-Z]+\\)"
139 (1 font-lock-string-face
)
140 (2 font-lock-keyword-face
))
141 ("^)\\([A-Z ]+\\)\\([a-z ]+\\)"
142 (1 font-lock-keyword-face
)
143 (2 font-lock-string-face
)))
144 "Expressions to fontify in Decipher mode.
146 Ciphertext uses `font-lock-keyword-face', plaintext uses
147 `font-lock-string-face', comments use `font-lock-comment-face', and
148 checkpoints use `font-lock-constant-face'. You can customize the
149 display by changing these variables. For best results, I recommend
150 that all faces use the same background color.
152 For example, to display ciphertext in the `bold' face, use
153 (add-hook 'decipher-mode-hook
154 (lambda () (set (make-local-variable 'font-lock-keyword-face)
156 in your `.emacs' file.")
158 (defvar decipher-mode-map nil
159 "Keymap for Decipher mode.")
160 (if (not decipher-mode-map
)
162 (setq decipher-mode-map
(make-keymap))
163 (suppress-keymap decipher-mode-map
)
164 (define-key decipher-mode-map
"A" 'decipher-show-alphabet
)
165 (define-key decipher-mode-map
"C" 'decipher-complete-alphabet
)
166 (define-key decipher-mode-map
"D" 'decipher-digram-list
)
167 (define-key decipher-mode-map
"F" 'decipher-frequency-count
)
168 (define-key decipher-mode-map
"M" 'decipher-make-checkpoint
)
169 (define-key decipher-mode-map
"N" 'decipher-adjacency-list
)
170 (define-key decipher-mode-map
"R" 'decipher-restore-checkpoint
)
171 (define-key decipher-mode-map
"U" 'decipher-undo
)
172 (define-key decipher-mode-map
" " 'decipher-keypress
)
173 (substitute-key-definition 'undo
'decipher-undo
174 decipher-mode-map global-map
)
175 (substitute-key-definition 'advertised-undo
'decipher-undo
176 decipher-mode-map global-map
)
179 (define-key decipher-mode-map
(vector key
) 'decipher-keypress
)
182 (defvar decipher-stats-mode-map nil
183 "Keymap for Decipher-Stats mode.")
184 (if (not decipher-stats-mode-map
)
186 (setq decipher-stats-mode-map
(make-keymap))
187 (suppress-keymap decipher-stats-mode-map
)
188 (define-key decipher-stats-mode-map
"D" 'decipher-digram-list
)
189 (define-key decipher-stats-mode-map
"F" 'decipher-frequency-count
)
190 (define-key decipher-stats-mode-map
"N" 'decipher-adjacency-list
)
193 (defvar decipher-mode-syntax-table nil
194 "Decipher mode syntax table")
196 (if decipher-mode-syntax-table
198 (let ((table (make-syntax-table))
201 (modify-syntax-entry c
"_" table
) ;Digits are not part of words
203 (setq decipher-mode-syntax-table table
)))
205 (defvar decipher-alphabet nil
)
206 ;; This is an alist containing entries (PLAIN-CHAR . CIPHER-CHAR),
207 ;; where PLAIN-CHAR runs from ?a to ?z and CIPHER-CHAR is an uppercase
208 ;; letter or space (which means no mapping is known for that letter).
209 ;; This *must* contain entries for all lowercase characters.
210 (make-variable-buffer-local 'decipher-alphabet
)
212 (defvar decipher-stats-buffer nil
213 "The buffer which displays statistics for this ciphertext.
214 Do not access this variable directly, use the function
215 `decipher-stats-buffer' instead.")
216 (make-variable-buffer-local 'decipher-stats-buffer
)
218 (defvar decipher-undo-list-size
0
219 "The number of entries in the undo list.")
220 (make-variable-buffer-local 'decipher-undo-list-size
)
222 (defvar decipher-undo-list nil
223 "The undo list for this buffer.
224 Each element is either a cons cell (PLAIN-CHAR . CIPHER-CHAR) or a
225 list of such cons cells.")
226 (make-variable-buffer-local 'decipher-undo-list
)
228 (defvar decipher-pending-undo-list nil
)
230 ;; The following variables are used by the analysis functions
231 ;; and are defined here to avoid byte-compiler warnings.
232 ;; Don't mess with them unless you know what you're doing.
233 (defvar decipher-char nil
234 "See the functions decipher-loop-with-breaks and decipher-loop-no-breaks.")
235 (defvar decipher--prev-char
)
236 (defvar decipher--digram
)
237 (defvar decipher--digram-list
)
238 (defvar decipher--before
)
239 (defvar decipher--after
)
240 (defvar decipher--freqs
)
242 ;;;===================================================================
244 ;;;===================================================================
245 ;; Main entry points:
246 ;;--------------------------------------------------------------------
250 "Format a buffer of ciphertext for cryptanalysis and enter Decipher mode."
252 ;; Make sure the buffer ends in a newline:
253 (goto-char (point-max))
256 ;; See if it's already in decipher format:
257 (goto-char (point-min))
258 (if (looking-at "^(abcdefghijklmnopqrstuvwxyz \
259 ABCDEFGHIJKLMNOPQRSTUVWXYZ -\\*-decipher-\\*-\n)")
260 (message "Buffer is already formatted, entering Decipher mode...")
261 ;; Add the alphabet at the beginning of the file
262 (insert "(abcdefghijklmnopqrstuvwxyz \
263 ABCDEFGHIJKLMNOPQRSTUVWXYZ -*-decipher-*-\n)\n\n")
264 ;; Add lines for the solution:
267 (if (looking-at "^%")
268 (forward-line) ;Leave comments alone
269 (delete-horizontal-space)
271 (forward-line) ;Just leave blank lines alone
272 (insert ":") ;Mark ciphertext line
275 (if decipher-force-uppercase
276 (upcase-region begin
(point))) ;Convert ciphertext to uppercase
277 (insert ">\n"))))) ;Mark plaintext line
278 (delete-blank-lines) ;Remove any blank lines
279 (delete-blank-lines)) ; at end of buffer
284 (defun decipher-mode ()
285 "Major mode for decrypting monoalphabetic substitution ciphers.
286 Lower-case letters enter plaintext.
287 Upper-case letters are commands.
289 The buffer is made read-only so that normal Emacs commands cannot
292 The most useful commands are:
293 \\<decipher-mode-map>
294 \\[decipher-digram-list] Display a list of all digrams & their frequency
295 \\[decipher-frequency-count] Display the frequency of each ciphertext letter
296 \\[decipher-adjacency-list]\
297 Show adjacency list for current letter (lists letters appearing next to it)
298 \\[decipher-make-checkpoint] Save the current cipher alphabet (checkpoint)
299 \\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)"
301 (kill-all-local-variables)
302 (setq buffer-undo-list t
;Disable undo
303 indent-tabs-mode nil
;Do not use tab characters
304 major-mode
'decipher-mode
305 mode-name
"Decipher")
306 (if decipher-force-uppercase
307 (setq case-fold-search nil
)) ;Case is significant when searching
308 (use-local-map decipher-mode-map
)
309 (set-syntax-table decipher-mode-syntax-table
)
310 (decipher-read-alphabet)
311 (set (make-local-variable 'font-lock-defaults
)
312 '(decipher-font-lock-keywords t
))
313 ;; Make the buffer writable when we exit Decipher mode:
314 (make-local-hook 'change-major-mode-hook
)
315 (add-hook 'change-major-mode-hook
316 (lambda () (setq buffer-read-only nil
317 buffer-undo-list nil
))
319 (run-hooks 'decipher-mode-hook
)
320 (setq buffer-read-only t
))
321 (put 'decipher-mode
'mode-class
'special
)
323 ;;--------------------------------------------------------------------
324 ;; Normal key handling:
325 ;;--------------------------------------------------------------------
327 (defmacro decipher-last-command-char
()
328 ;; Return the char which ran this command (for compatibility with XEmacs)
329 (if (fboundp 'event-to-character
)
330 '(event-to-character last-command-event
)
331 'last-command-event
))
333 (defun decipher-keypress ()
334 "Enter a plaintext or ciphertext character."
336 (let ((decipher-function 'decipher-set-map
)
337 buffer-read-only
) ;Make buffer writable
341 (let ((first-char (following-char)))
348 (setq decipher-function
'decipher-alphabet-keypress
)
351 (setq decipher-function
'decipher-alphabet-keypress
)
354 (error "Bad location")))))
357 (let ((char-a (following-char))
358 (char-b (decipher-last-command-char)))
359 (or (and (not (= ?w
(char-syntax char-a
)))
360 (= char-b ?\
)) ;Spacebar just advances on non-letters
361 (funcall decipher-function char-a char-b
)))))
364 (defun decipher-alphabet-keypress (a b
)
365 ;; Handle keypresses in the alphabet lines.
366 ;; A is the character in the alphabet row (which starts with '(')
367 ;; B is the character pressed
368 (cond ((and (>= a ?A
) (<= a ?Z
))
369 ;; If A is uppercase, then it is in the ciphertext alphabet:
370 (decipher-set-map a b
))
371 ((and (>= a ?a
) (<= a ?z
))
372 ;; If A is lowercase, then it is in the plaintext alphabet:
374 ;; We are clearing the association (if any):
375 (if (/= ?\
(setq b
(cdr (assoc a decipher-alphabet
))))
376 (decipher-set-map b ?\
))
377 ;; Associate the plaintext char with the char pressed:
378 (decipher-set-map b a
)))
380 ;; If A is not a letter, that's a problem:
381 (error "Bad character"))))
383 ;;--------------------------------------------------------------------
385 ;;--------------------------------------------------------------------
387 (defun decipher-undo ()
388 "Undo a change in Decipher mode."
390 ;; If we don't get all the way thru, make last-command indicate that
391 ;; for the following command.
392 (setq this-command t
)
393 (or (eq major-mode
'decipher-mode
)
394 (error "This buffer is not in Decipher mode"))
395 (or (eq last-command
'decipher-undo
)
396 (setq decipher-pending-undo-list decipher-undo-list
))
397 (or decipher-pending-undo-list
398 (error "No further undo information"))
399 (let ((undo-rec (pop decipher-pending-undo-list
))
400 buffer-read-only
;Make buffer writable
401 redo-map redo-rec undo-map
)
402 (or (consp (car undo-rec
))
403 (setq undo-rec
(list undo-rec
)))
404 (while (setq undo-map
(pop undo-rec
))
405 (setq redo-map
(decipher-get-undo (cdr undo-map
) (car undo-map
)))
408 (if (consp (car redo-map
))
409 (append redo-map redo-rec
)
410 (cons redo-map redo-rec
))))
411 (decipher-set-map (cdr undo-map
) (car undo-map
) t
))
412 (decipher-add-undo redo-rec
))
413 (setq this-command
'decipher-undo
)
416 (defun decipher-add-undo (undo-rec)
417 "Add UNDO-REC to the undo list."
420 (push undo-rec decipher-undo-list
)
421 (incf decipher-undo-list-size
)
422 (if (> decipher-undo-list-size decipher-undo-limit
)
423 (let ((new-size (- decipher-undo-limit
100)))
424 ;; Truncate undo list to NEW-SIZE elements:
425 (setcdr (nthcdr (1- new-size
) decipher-undo-list
) nil
)
426 (setq decipher-undo-list-size new-size
))))))
428 (defun decipher-copy-cons (cons)
430 (cons (car cons
) (cdr cons
))))
432 (defun decipher-get-undo (cipher-char plain-char
)
433 ;; Return an undo record that will undo the result of
434 ;; (decipher-set-map CIPHER-CHAR PLAIN-CHAR)
435 ;; We must copy the cons cell because the original cons cells will be
436 ;; modified using setcdr.
437 (let ((cipher-map (decipher-copy-cons (rassoc cipher-char decipher-alphabet
)))
438 (plain-map (decipher-copy-cons (assoc plain-char decipher-alphabet
))))
439 (cond ((equal ?\ plain-char
)
441 ((equal cipher-char
(cdr plain-map
))
442 nil
) ;We aren't changing anything
443 ((equal ?\
(cdr plain-map
))
444 (or cipher-map
(cons ?\ cipher-char
)))
446 (list plain-map cipher-map
))
450 ;;--------------------------------------------------------------------
451 ;; Mapping ciphertext and plaintext:
452 ;;--------------------------------------------------------------------
454 (defun decipher-set-map (cipher-char plain-char
&optional no-undo
)
455 ;; Associate a ciphertext letter with a plaintext letter
456 ;; CIPHER-CHAR must be an uppercase or lowercase letter
457 ;; PLAIN-CHAR must be a lowercase letter (or a space)
458 ;; NO-UNDO if non-nil means do not record undo information
459 ;; Any existing associations for CIPHER-CHAR or PLAIN-CHAR will be erased.
460 (setq cipher-char
(upcase cipher-char
))
461 (or (and (>= cipher-char ?A
) (<= cipher-char ?Z
))
462 (error "Bad character")) ;Cipher char must be uppercase letter
464 (decipher-add-undo (decipher-get-undo cipher-char plain-char
)))
465 (let ((cipher-string (char-to-string cipher-char
))
466 (plain-string (char-to-string plain-char
))
467 case-fold-search
;Case is significant
470 (goto-char (point-min))
471 (if (setq mapping
(rassoc cipher-char decipher-alphabet
))
474 (search-forward-regexp (concat "^([a-z]*"
475 (char-to-string (car mapping
))))
476 (decipher-insert ?\
)
477 (beginning-of-line)))
478 (if (setq mapping
(assoc plain-char decipher-alphabet
))
480 (if (/= ?\
(cdr mapping
))
481 (decipher-set-map (cdr mapping
) ?\ t
))
482 (setcdr mapping cipher-char
)
483 (search-forward-regexp (concat "^([a-z]*" plain-string
))
484 (decipher-insert cipher-char
)
485 (beginning-of-line)))
486 (search-forward-regexp (concat "^([a-z]+ [A-Z]*" cipher-string
))
487 (decipher-insert plain-char
)
488 (setq case-fold-search t
;Case is not significant
489 cipher-string
(downcase cipher-string
))
490 (let ((font-lock-fontify-region-function 'ignore
))
491 ;; insert-and-inherit will pick the right face automatically
492 (while (search-forward-regexp "^:" nil t
)
493 (setq bound
(save-excursion (end-of-line) (point)))
494 (while (search-forward cipher-string bound
'end
)
495 (decipher-insert plain-char
)))))))
497 (defun decipher-insert (char)
498 ;; Insert CHAR in the row below point. It replaces any existing
499 ;; character in that position.
500 (let ((col (1- (current-column))))
503 (or (= ?\
> (following-char))
504 (= ?\
) (following-char))
505 (error "Bad location"))
506 (move-to-column col t
)
509 (insert-and-inherit char
))))
511 ;;--------------------------------------------------------------------
513 ;;--------------------------------------------------------------------
514 ;; A checkpoint is a comment of the form:
515 ;; %!ABCDEFGHIJKLMNOPQRSTUVWXYZ! Description
516 ;; Such comments are usually placed at the end of the buffer following
517 ;; this header (which is inserted by decipher-make-checkpoint):
518 ;; %---------------------------
520 ;; % abcdefghijklmnopqrstuvwxyz
521 ;; but this is not required; checkpoints can be placed anywhere.
523 ;; The description is optional; all that is required is the alphabet.
525 (defun decipher-make-checkpoint (desc)
526 "Checkpoint the current cipher alphabet.
527 This records the current alphabet so you can return to it later.
528 You may have any number of checkpoints.
529 Type `\\[decipher-restore-checkpoint]' to restore a checkpoint."
530 (interactive "sCheckpoint description: ")
534 buffer-read-only
;Make buffer writable
536 (goto-char (point-min))
537 (re-search-forward "^)")
538 (move-to-column 27 t
)
539 (setq alphabet
(buffer-substring-no-properties (- (point) 26) (point)))
540 (if (re-search-forward "^%![A-Z ]+!" nil
'end
)
541 nil
; Add new checkpoint with others
542 (if (re-search-backward "^% *Local Variables:" nil t
)
543 ;; Add checkpoints before local variables list:
544 (progn (forward-line -
1)
545 (or (looking-at "^ *$")
546 (progn (forward-line) (insert ?
\n) (forward-line -
1)))))
547 (insert "\n%" (make-string 69 ?\-
)
548 "\n% Checkpoints:\n% abcdefghijklmnopqrstuvwxyz\n"))
550 (insert "%!" alphabet
"! " desc ?
\n)))
552 (defun decipher-restore-checkpoint ()
553 "Restore the cipher alphabet from a checkpoint.
554 If point is not on a checkpoint line, moves to the first checkpoint line.
555 If point is on a checkpoint, restores that checkpoint.
557 Type `\\[decipher-make-checkpoint]' to make a checkpoint."
560 (if (looking-at "%!\\([A-Z ]+\\)!")
561 ;; Restore this checkpoint:
562 (let ((alphabet (match-string 1))
563 buffer-read-only
) ;Make buffer writable
564 (goto-char (point-min))
565 (re-search-forward "^)")
567 (delete-region (point) (progn (end-of-line) (point))))
570 ;; Move to the first checkpoint:
571 (goto-char (point-min))
572 (if (re-search-forward "^%![A-Z ]+!" nil t
)
573 (message "Select the checkpoint to restore and type `%s'"
574 (substitute-command-keys "\\[decipher-restore-checkpoint]"))
575 (error "No checkpoints in this buffer"))))
577 ;;--------------------------------------------------------------------
578 ;; Miscellaneous commands:
579 ;;--------------------------------------------------------------------
581 (defun decipher-complete-alphabet ()
582 "Complete the cipher alphabet.
583 This fills any blanks in the cipher alphabet with the unused letters
584 in alphabetical order. Use this when you have a keyword cipher and
585 you have determined the keyword."
587 (let ((cipher-char ?A
)
588 (ptr decipher-alphabet
)
589 buffer-read-only
;Make buffer writable
591 (while (setq plain-map
(pop ptr
))
592 (if (equal ?\
(cdr plain-map
))
594 (while (rassoc cipher-char decipher-alphabet
)
595 ;; Find the next unused letter
597 (push (cons ?\ cipher-char
) undo-rec
)
598 (decipher-set-map cipher-char
(car plain-map
) t
))))
599 (decipher-add-undo undo-rec
)))
601 (defun decipher-show-alphabet ()
602 "Display the current cipher alphabet in the message line."
605 (mapconcat (lambda (a)
607 (char-to-string (car a
))
608 (char-to-string (cdr a
))))
612 (defun decipher-resync ()
613 "Reprocess the buffer using the alphabet from the top.
614 This regenerates all deciphered plaintext and clears the undo list.
615 You should use this if you edit the ciphertext."
617 (message "Reprocessing buffer...")
619 buffer-read-only
;Make buffer writable
622 (decipher-read-alphabet)
623 (setq alphabet decipher-alphabet
)
624 (goto-char (point-min))
625 (and (re-search-forward "^).+" nil t
)
626 (replace-match ")" nil nil
))
627 (while (re-search-forward "^>.+" nil t
)
628 (replace-match ">" nil nil
))
629 (decipher-read-alphabet)
630 (while (setq mapping
(pop alphabet
))
631 (or (equal ?\
(cdr mapping
))
632 (decipher-set-map (cdr mapping
) (car mapping
))))))
633 (setq decipher-undo-list nil
634 decipher-undo-list-size
0)
635 (message "Reprocessing buffer...done"))
637 ;;--------------------------------------------------------------------
638 ;; Miscellaneous functions:
639 ;;--------------------------------------------------------------------
641 (defun decipher-read-alphabet ()
642 "Build the decipher-alphabet from the alphabet line in the buffer."
644 (goto-char (point-min))
645 (search-forward-regexp "^)")
646 (move-to-column 27 t
)
647 (setq decipher-alphabet nil
)
648 (let ((plain-char ?z
))
649 (while (>= plain-char ?a
)
651 (push (cons plain-char
(following-char)) decipher-alphabet
)
652 (decf plain-char
)))))
654 ;;;===================================================================
655 ;;; Analyzing ciphertext:
656 ;;;===================================================================
658 (defun decipher-frequency-count ()
659 "Display the frequency count in the statistics buffer."
662 (decipher-display-regexp "^A" "^[A-Z][A-Z]"))
664 (defun decipher-digram-list ()
665 "Display the list of digrams in the statistics buffer."
668 (decipher-display-regexp "[A-Z][A-Z] +[0-9]" "^$"))
670 (defun decipher-adjacency-list (cipher-char)
671 "Display the adjacency list for the letter at point.
672 The adjacency list shows all letters which come next to CIPHER-CHAR.
674 An adjacency list (for the letter X) looks like this:
676 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%
678 This says that X comes before D once, and after B once. X begins 5
679 words, and ends 3 words (`*' represents a space). X comes before 8
680 different letters, after 7 differerent letters, and is next to a total
681 of 11 different letters. It occurs 14 times, making up 9% of the
683 (interactive (list (upcase (following-char))))
687 (set-buffer (decipher-stats-buffer))
688 (goto-char (point-min))
689 (or (re-search-forward (format "^%c: " cipher-char
) nil t
)
690 (error "Character `%c' is not used in ciphertext." cipher-char
))
695 (decipher-display-range start end
)))
697 ;;--------------------------------------------------------------------
698 (defun decipher-analyze ()
699 "Perform frequency analysis on the current buffer if necessary."
701 ;; If this is the statistics buffer, do nothing:
702 ((eq major-mode
'decipher-stats-mode
))
703 ;; If this is the Decipher buffer, see if the stats buffer exists:
704 ((eq major-mode
'decipher-mode
)
705 (or (and (bufferp decipher-stats-buffer
)
706 (buffer-name decipher-stats-buffer
))
707 (decipher-analyze-buffer)))
709 (t (error "This buffer is not in Decipher mode"))))
711 ;;--------------------------------------------------------------------
712 (defun decipher-display-range (start end
)
713 "Display text between START and END in the statistics buffer.
714 START and END are positions in the statistics buffer. Makes the
715 statistics buffer visible and sizes the window to just fit the
716 displayed text, but leaves the current window selected."
717 (let ((stats-buffer (decipher-stats-buffer))
718 (current-window (selected-window))
720 (or (eq (current-buffer) stats-buffer
)
721 (pop-to-buffer stats-buffer
))
724 (enlarge-window (- (1+ (count-lines start end
)) (window-height))))
726 (select-window current-window
)))
728 (defun decipher-display-regexp (start-regexp end-regexp
)
729 "Display text between two regexps in the statistics buffer.
731 START-REGEXP matches the first line to display.
732 END-REGEXP matches the line after that which ends the display.
733 The ending line is included in the display unless it is blank."
736 (set-buffer (decipher-stats-buffer))
737 (goto-char (point-min))
738 (re-search-forward start-regexp
)
741 (re-search-forward end-regexp
)
743 (or (looking-at "^ *$")
746 (decipher-display-range start end
)))
748 ;;--------------------------------------------------------------------
749 (defun decipher-loop-with-breaks (func)
750 "Loop through ciphertext, calling FUNC once for each letter & word division.
752 FUNC is called with no arguments, and its return value is unimportant.
753 It may examine `decipher-char' to see the current ciphertext
754 character. `decipher-char' contains either an uppercase letter or a space.
756 FUNC is called exactly once between words, with `decipher-char' set to
759 See `decipher-loop-no-breaks' if you do not care about word divisions."
760 (let ((decipher-char ?\
)
761 (decipher--loop-prev-char ?\
))
763 (goto-char (point-min))
764 (funcall func
) ;Space marks beginning of first word
765 (while (search-forward-regexp "^:" nil t
)
767 (setq decipher-char
(upcase (following-char)))
768 (or (and (>= decipher-char ?A
) (<= decipher-char ?Z
))
769 (setq decipher-char ?\
))
770 (or (and (equal decipher-char ?\
)
771 (equal decipher--loop-prev-char ?\
))
773 (setq decipher--loop-prev-char decipher-char
)
775 (or (equal decipher-char ?\
)
777 (setq decipher-char ?\
;
778 decipher--loop-prev-char ?\
)
781 (defun decipher-loop-no-breaks (func)
782 "Loop through ciphertext, calling FUNC once for each letter.
784 FUNC is called with no arguments, and its return value is unimportant.
785 It may examine `decipher-char' to see the current ciphertext letter.
786 `decipher-char' contains an uppercase letter.
788 Punctuation and spacing in the ciphertext are ignored.
789 See `decipher-loop-with-breaks' if you care about word divisions."
792 (goto-char (point-min))
793 (while (search-forward-regexp "^:" nil t
)
795 (setq decipher-char
(upcase (following-char)))
796 (and (>= decipher-char ?A
)
797 (<= decipher-char ?Z
)
801 ;;--------------------------------------------------------------------
802 ;; Perform the analysis:
803 ;;--------------------------------------------------------------------
805 (defun decipher-insert-frequency-counts (freq-list total
)
806 "Insert frequency counts in current buffer.
807 Each element of FREQ-LIST is a list (LETTER FREQ ...).
808 TOTAL is the total number of letters in the ciphertext."
809 (let ((i 4) temp-list
)
811 (setq temp-list freq-list
)
813 (insert (caar temp-list
)
816 (/ (* 100 (cadar temp-list
)) total
)))
817 (setq temp-list
(nthcdr 4 temp-list
)))
819 (setq freq-list
(cdr freq-list
)
822 (defun decipher--analyze ()
823 ;; Perform frequency analysis on ciphertext.
825 ;; This function is called repeatedly with decipher-char set to each
826 ;; character of ciphertext. It uses decipher--prev-char to remember
827 ;; the previous ciphertext character.
829 ;; It builds several data structures, which must be initialized
830 ;; before the first call to decipher--analyze. The arrays are
831 ;; indexed with A = 0, B = 1, ..., Z = 25, SPC = 26 (if used).
832 ;; decipher--after: (initialize to zeros)
833 ;; A vector of 26 vectors of 27 integers. The first vector
834 ;; represents the number of times A follows each character, the
835 ;; second vector represents B, and so on.
836 ;; decipher--before: (initialize to zeros)
837 ;; The same as decipher--after, but representing the number of
838 ;; times the character precedes each other character.
839 ;; decipher--digram-list: (initialize to nil)
840 ;; An alist with an entry for each digram (2-character sequence)
841 ;; encountered. Each element is a cons cell (DIGRAM . FREQ),
842 ;; where DIGRAM is a 2 character string and FREQ is the number
843 ;; of times it occurs.
844 ;; decipher--freqs: (initialize to zeros)
845 ;; A vector of 26 integers, counting the number of occurrences
846 ;; of the corresponding characters.
847 (setq decipher--digram
(format "%c%c" decipher--prev-char decipher-char
))
848 (incf (cdr (or (assoc decipher--digram decipher--digram-list
)
849 (car (push (cons decipher--digram
0)
850 decipher--digram-list
)))))
851 (and (>= decipher--prev-char ?A
)
852 (incf (aref (aref decipher--before
(- decipher--prev-char ?A
))
853 (if (equal decipher-char ?\
)
855 (- decipher-char ?A
)))))
856 (and (>= decipher-char ?A
)
857 (incf (aref decipher--freqs
(- decipher-char ?A
)))
858 (incf (aref (aref decipher--after
(- decipher-char ?A
))
859 (if (equal decipher--prev-char ?\
)
861 (- decipher--prev-char ?A
)))))
862 (setq decipher--prev-char decipher-char
))
864 (defun decipher--digram-counts (counts)
865 "Generate the counts for an adjacency list."
868 (mapconcat (lambda (x)
869 (cond ((> x
99) (incf total
) "XX")
870 ((> x
0) (incf total
) (format "%2d" x
))
874 (format "%4d" (if (> (aref counts
26) 0)
875 (1- total
) ;Don't count space
878 (defun decipher--digram-total (before-count after-count
)
879 "Count the number of different letters a letter appears next to."
880 ;; We do not include spaces (word divisions) in this count.
883 (while (>= (decf i
) 0)
884 (if (or (> (aref before-count i
) 0)
885 (> (aref after-count i
) 0))
889 (defun decipher-analyze-buffer ()
890 "Perform frequency analysis and store results in statistics buffer.
891 Creates the statistics buffer if it doesn't exist."
892 (let ((decipher--prev-char (if decipher-ignore-spaces ?\ ?\
*))
893 (decipher--before (make-vector 26 nil
))
894 (decipher--after (make-vector 26 nil
))
895 (decipher--freqs (make-vector 26 0))
897 decipher--digram decipher--digram-list freq-list
)
898 (message "Scanning buffer...")
900 (while (>= (decf i
) 0)
901 (aset decipher--before i
(make-vector 27 0))
902 (aset decipher--after i
(make-vector 27 0))))
903 (if decipher-ignore-spaces
905 (decipher-loop-no-breaks 'decipher--analyze
)
906 ;; The first character of ciphertext was marked as following a space:
908 (while (>= (decf i
) 0)
909 (aset (aref decipher--after i
) 26 0))))
910 (decipher-loop-with-breaks 'decipher--analyze
))
911 (message "Processing results...")
912 (setcdr (last decipher--digram-list
2) nil
) ;Delete the phony "* " digram
913 ;; Sort the digram list by frequency and alphabetical order:
914 (setq decipher--digram-list
(sort (sort decipher--digram-list
915 (lambda (a b
) (string< (car a
) (car b
))))
916 (lambda (a b
) (> (cdr a
) (cdr b
)))))
917 ;; Generate the frequency list:
918 ;; Each element is a list of 3 elements (LETTER FREQ DIFFERENT),
919 ;; where LETTER is the ciphertext character, FREQ is the number
920 ;; of times it occurs, and DIFFERENT is the number of different
921 ;; letters it appears next to.
923 (while (>= (decf i
) 0)
926 (aref decipher--freqs i
)
927 (decipher--digram-total (aref decipher--before i
)
928 (aref decipher--after i
)))
930 total-chars
(+ total-chars
(aref decipher--freqs i
)))))
932 ;; Switch to statistics buffer, creating it if necessary:
933 (set-buffer (decipher-stats-buffer t
))
934 ;; This can't happen, but it never hurts to double-check:
935 (or (eq major-mode
'decipher-stats-mode
)
936 (error "Buffer %s is not in Decipher-Stats mode" (buffer-name)))
937 (setq buffer-read-only nil
)
939 ;; Display frequency counts for letters A-Z:
940 (decipher-insert-frequency-counts freq-list total-chars
)
942 ;; Display frequency counts for letters in order of frequency:
943 (setq freq-list
(sort freq-list
944 (lambda (a b
) (> (second a
) (second b
)))))
945 (decipher-insert-frequency-counts freq-list total-chars
)
946 ;; Display letters in order of frequency:
947 (insert ?
\n (mapconcat (lambda (a) (char-to-string (car a
)))
950 ;; Display list of digrams in order of frequency:
951 (let* ((rows (floor (+ (length decipher--digram-list
) 9) 10))
955 (setq temp-list decipher--digram-list
)
957 (insert (caar temp-list
)
960 (setq temp-list
(nthcdr rows temp-list
)))
961 (delete-horizontal-space)
963 (setq decipher--digram-list
(cdr decipher--digram-list
)
965 ;; Display adjacency list for each letter, sorted in descending
966 ;; order of the number of adjacent letters:
967 (setq freq-list
(sort freq-list
968 (lambda (a b
) (> (third a
) (third b
)))))
969 (let ((temp-list freq-list
)
971 (while (setq entry
(pop temp-list
))
972 (if (equal 0 (second entry
))
973 nil
;This letter was not used
974 (setq i
(- (car entry
) ?A
))
976 (decipher--digram-counts (aref decipher--before i
)) ?
\n
978 ": 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 *"
979 (format "%4d %4d %3d%%\n "
980 (third entry
) (second entry
)
981 (/ (* 100 (second entry
)) total-chars
))
982 (decipher--digram-counts (aref decipher--after i
)) ?
\n))))
983 (setq buffer-read-only t
)
984 (set-buffer-modified-p nil
)
988 ;;====================================================================
989 ;; Statistics Buffer:
990 ;;====================================================================
992 (defun decipher-stats-mode ()
993 "Major mode for displaying ciphertext statistics."
995 (kill-all-local-variables)
996 (setq buffer-read-only t
997 buffer-undo-list t
;Disable undo
998 case-fold-search nil
;Case is significant when searching
999 indent-tabs-mode nil
;Do not use tab characters
1000 major-mode
'decipher-stats-mode
1001 mode-name
"Decipher-Stats")
1002 (use-local-map decipher-stats-mode-map
)
1003 (run-hooks 'decipher-stats-mode-hook
))
1004 (put 'decipher-stats-mode
'mode-class
'special
)
1006 ;;--------------------------------------------------------------------
1008 (defun decipher-display-stats-buffer ()
1009 "Make the statistics buffer visible, but do not select it."
1010 (let ((stats-buffer (decipher-stats-buffer))
1011 (current-window (selected-window)))
1012 (or (eq (current-buffer) stats-buffer
)
1014 (pop-to-buffer stats-buffer
)
1015 (select-window current-window
)))))
1017 (defun decipher-stats-buffer (&optional create
)
1018 "Return the buffer used for decipher statistics.
1019 If CREATE is non-nil, create the buffer if it doesn't exist.
1020 This is guaranteed to return a buffer in Decipher-Stats mode;
1021 if it can't, it signals an error."
1023 ;; We may already be in the statistics buffer:
1024 ((eq major-mode
'decipher-stats-mode
)
1026 ;; See if decipher-stats-buffer exists:
1027 ((and (bufferp decipher-stats-buffer
)
1028 (buffer-name decipher-stats-buffer
))
1030 (set-buffer decipher-stats-buffer
)
1031 (eq major-mode
'decipher-stats-mode
))
1032 (error "Buffer %s is not in Decipher-Stats mode"
1033 (buffer-name decipher-stats-buffer
)))
1034 decipher-stats-buffer
)
1035 ;; Create a new buffer if requested:
1037 (let ((stats-name (concat "*" (buffer-name) "*")))
1038 (setq decipher-stats-buffer
1039 (if (eq 'decipher-stats-mode
1040 (cdr-safe (assoc 'major-mode
1041 (buffer-local-variables
1042 (get-buffer stats-name
)))))
1043 ;; We just lost track of the statistics buffer:
1044 (get-buffer stats-name
)
1045 (generate-new-buffer stats-name
))))
1047 (set-buffer decipher-stats-buffer
)
1048 (decipher-stats-mode))
1049 decipher-stats-buffer
)
1051 (t (error "No statistics buffer"))))
1053 ;;====================================================================
1057 ;;;(defun decipher-show-undo-list ()
1058 ;;; "Display the undo list (for debugging purposes)."
1060 ;;; (with-output-to-temp-buffer "*Decipher Undo*"
1061 ;;; (let ((undo-list decipher-undo-list)
1062 ;;; undo-rec undo-map)
1064 ;;; (set-buffer "*Decipher Undo*")
1065 ;;; (while (setq undo-rec (pop undo-list))
1066 ;;; (or (consp (car undo-rec))
1067 ;;; (setq undo-rec (list undo-rec)))
1069 ;;; (while (setq undo-map (pop undo-rec))
1070 ;;; (insert (cdr undo-map) (car undo-map) ?\ ))
1071 ;;; (delete-backward-char 1)
1072 ;;; (insert ")\n"))))))
1074 ;;; decipher.el ends here
HCoop / bpt / emacs.git / blob