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