-;;; decipher.el --- Cryptanalyze monoalphabetic substitution ciphers
+;;; decipher.el --- cryptanalyze monoalphabetic substitution ciphers
;;
-;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1996, 2001-2015 Free Software Foundation, Inc.
;;
;; Author: Christopher J. Madsen <chris_madsen@geocities.com>
;; Keywords: games
;;
;; This file is part of GNU Emacs.
;;
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
-;;
+
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;;; Variables:
;;;===================================================================
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defgroup decipher nil
"Cryptanalyze monoalphabetic substitution ciphers."
:group 'games)
(defcustom decipher-force-uppercase t
- "*Non-nil means to convert ciphertext to uppercase.
-Nil means the case of the ciphertext is preserved.
+ "Non-nil means to convert ciphertext to uppercase.
+nil means the case of the ciphertext is preserved.
This variable must be set before typing `\\[decipher]'."
:type 'boolean
:group 'decipher)
(defcustom decipher-ignore-spaces nil
- "*Non-nil means to ignore spaces and punctuation when counting digrams.
-You should set this to `nil' if the cipher message is divided into words,
-or `t' if it is not.
+ "Non-nil means to ignore spaces and punctuation when counting digrams.
+You should set this to nil if the cipher message is divided into words,
+or t if it is not.
This variable is buffer-local."
:type 'boolean
:group 'decipher)
("^)\\([A-Z ]+\\)\\([a-z ]+\\)"
(1 font-lock-keyword-face)
(2 font-lock-string-face)))
- "Expressions to fontify in Decipher mode.
+ "Font Lock keywords for Decipher mode.")
+
+(defvar decipher-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map)
+ (define-key map "A" 'decipher-show-alphabet)
+ (define-key map "C" 'decipher-complete-alphabet)
+ (define-key map "D" 'decipher-digram-list)
+ (define-key map "F" 'decipher-frequency-count)
+ (define-key map "M" 'decipher-make-checkpoint)
+ (define-key map "N" 'decipher-adjacency-list)
+ (define-key map "R" 'decipher-restore-checkpoint)
+ (define-key map "U" 'decipher-undo)
+ (define-key map " " 'decipher-keypress)
+ (define-key map [remap undo] 'decipher-undo)
+ (define-key map [remap advertised-undo] 'decipher-undo)
+ (let ((key ?a))
+ (while (<= key ?z)
+ (define-key map (vector key) 'decipher-keypress)
+ (cl-incf key)))
+ map)
+ "Keymap for Decipher mode.")
-Ciphertext uses `font-lock-keyword-face', plaintext uses
-`font-lock-string-face', comments use `font-lock-comment-face', and
-checkpoints use `font-lock-constant-face'. You can customize the
-display by changing these variables. For best results, I recommend
-that all faces use the same background color.
-For example, to display ciphertext in the `bold' face, use
- (add-hook 'decipher-mode-hook
- (lambda () (set (make-local-variable 'font-lock-keyword-face)
- 'bold)))
-in your `.emacs' file.")
+(defvar decipher-stats-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map)
+ (define-key map "D" 'decipher-digram-list)
+ (define-key map "F" 'decipher-frequency-count)
+ (define-key map "N" 'decipher-adjacency-list)
+ map)
+"Keymap for Decipher-Stats mode.")
-(defvar decipher-mode-map nil
- "Keymap for Decipher mode.")
-(if (not decipher-mode-map)
- (progn
- (setq decipher-mode-map (make-keymap))
- (suppress-keymap decipher-mode-map)
- (define-key decipher-mode-map "A" 'decipher-show-alphabet)
- (define-key decipher-mode-map "C" 'decipher-complete-alphabet)
- (define-key decipher-mode-map "D" 'decipher-digram-list)
- (define-key decipher-mode-map "F" 'decipher-frequency-count)
- (define-key decipher-mode-map "M" 'decipher-make-checkpoint)
- (define-key decipher-mode-map "N" 'decipher-adjacency-list)
- (define-key decipher-mode-map "R" 'decipher-restore-checkpoint)
- (define-key decipher-mode-map "U" 'decipher-undo)
- (define-key decipher-mode-map " " 'decipher-keypress)
- (substitute-key-definition 'undo 'decipher-undo
- decipher-mode-map global-map)
- (substitute-key-definition 'advertised-undo 'decipher-undo
- decipher-mode-map global-map)
- (let ((key ?a))
- (while (<= key ?z)
- (define-key decipher-mode-map (vector key) 'decipher-keypress)
- (incf key)))))
-
-(defvar decipher-stats-mode-map nil
- "Keymap for Decipher-Stats mode.")
-(if (not decipher-stats-mode-map)
- (progn
- (setq decipher-stats-mode-map (make-keymap))
- (suppress-keymap decipher-stats-mode-map)
- (define-key decipher-stats-mode-map "D" 'decipher-digram-list)
- (define-key decipher-stats-mode-map "F" 'decipher-frequency-count)
- (define-key decipher-stats-mode-map "N" 'decipher-adjacency-list)
- ))
(defvar decipher-mode-syntax-table nil
"Decipher mode syntax table")
(c ?0))
(while (<= c ?9)
(modify-syntax-entry c "_" table) ;Digits are not part of words
- (incf c))
+ (cl-incf c))
(setq decipher-mode-syntax-table table)))
(defvar decipher-alphabet nil)
(insert ">\n"))))) ;Mark plaintext line
(delete-blank-lines) ;Remove any blank lines
(delete-blank-lines)) ; at end of buffer
- (goto-line 4)
+ (goto-char (point-min))
+ (forward-line 3)
(decipher-mode))
;;;###autoload
(setq case-fold-search nil)) ;Case is significant when searching
(use-local-map decipher-mode-map)
(set-syntax-table decipher-mode-syntax-table)
- (decipher-read-alphabet)
+ (unless (= (point-min) (point-max))
+ (decipher-read-alphabet))
(set (make-local-variable 'font-lock-defaults)
'(decipher-font-lock-keywords t))
;; Make the buffer writable when we exit Decipher mode:
- (make-local-hook 'change-major-mode-hook)
(add-hook 'change-major-mode-hook
(lambda () (setq buffer-read-only nil
buffer-undo-list nil))
nil t)
- (run-hooks 'decipher-mode-hook)
+ (run-mode-hooks 'decipher-mode-hook)
(setq buffer-read-only t))
(put 'decipher-mode 'mode-class 'special)
(t
(error "Bad location")))))
(let (goal-column)
- (previous-line 1)))
+ (forward-line -1)))
(let ((char-a (following-char))
(char-b (decipher-last-command-char)))
(or (and (not (= ?w (char-syntax char-a)))
- (= char-b ?\ )) ;Spacebar just advances on non-letters
+ (= char-b ?\s)) ;Spacebar just advances on non-letters
(funcall decipher-function char-a char-b)))))
(forward-char))
(decipher-set-map a b))
((and (>= a ?a) (<= a ?z))
;; If A is lowercase, then it is in the plaintext alphabet:
- (if (= b ?\ )
+ (if (= b ?\s)
;; We are clearing the association (if any):
- (if (/= ?\ (setq b (cdr (assoc a decipher-alphabet))))
- (decipher-set-map b ?\ ))
+ (if (/= ?\s (setq b (cdr (assoc a decipher-alphabet))))
+ (decipher-set-map b ?\s))
;; Associate the plaintext char with the char pressed:
(decipher-set-map b a)))
(t
(if undo-rec
(progn
(push undo-rec decipher-undo-list)
- (incf decipher-undo-list-size)
+ (cl-incf decipher-undo-list-size)
(if (> decipher-undo-list-size decipher-undo-limit)
(let ((new-size (- decipher-undo-limit 100)))
;; Truncate undo list to NEW-SIZE elements:
;; modified using setcdr.
(let ((cipher-map (decipher-copy-cons (rassoc cipher-char decipher-alphabet)))
(plain-map (decipher-copy-cons (assoc plain-char decipher-alphabet))))
- (cond ((equal ?\ plain-char)
+ (cond ((equal ?\s plain-char)
cipher-map)
((equal cipher-char (cdr plain-map))
nil) ;We aren't changing anything
- ((equal ?\ (cdr plain-map))
- (or cipher-map (cons ?\ cipher-char)))
+ ((equal ?\s (cdr plain-map))
+ (or cipher-map (cons ?\s cipher-char)))
(cipher-map
(list plain-map cipher-map))
(t
(goto-char (point-min))
(if (setq mapping (rassoc cipher-char decipher-alphabet))
(progn
- (setcdr mapping ?\ )
+ (setcdr mapping ?\s)
(search-forward-regexp (concat "^([a-z]*"
(char-to-string (car mapping))))
- (decipher-insert ?\ )
+ (decipher-insert ?\s)
(beginning-of-line)))
(if (setq mapping (assoc plain-char decipher-alphabet))
(progn
- (if (/= ?\ (cdr mapping))
- (decipher-set-map (cdr mapping) ?\ t))
+ (if (/= ?\s (cdr mapping))
+ (decipher-set-map (cdr mapping) ?\s t))
(setcdr mapping cipher-char)
(search-forward-regexp (concat "^([a-z]*" plain-string))
(decipher-insert cipher-char)
(let ((font-lock-fontify-region-function 'ignore))
;; insert-and-inherit will pick the right face automatically
(while (search-forward-regexp "^:" nil t)
- (setq bound (save-excursion (end-of-line) (point)))
+ (setq bound (point-at-eol))
(while (search-forward cipher-string bound 'end)
(decipher-insert plain-char)))))))
(or (stringp desc)
(setq desc ""))
(let (alphabet
- buffer-read-only ;Make buffer writable
- mapping)
+ buffer-read-only) ;Make buffer writable
(goto-char (point-min))
(re-search-forward "^)")
(move-to-column 27 t)
buffer-read-only ;Make buffer writable
plain-map undo-rec)
(while (setq plain-map (pop ptr))
- (if (equal ?\ (cdr plain-map))
+ (if (equal ?\s (cdr plain-map))
(progn
(while (rassoc cipher-char decipher-alphabet)
;; Find the next unused letter
- (incf cipher-char))
- (push (cons ?\ cipher-char) undo-rec)
+ (cl-incf cipher-char))
+ (push (cons ?\s cipher-char) undo-rec)
(decipher-set-map cipher-char (car plain-map) t))))
(decipher-add-undo undo-rec)))
(defun decipher-show-alphabet ()
"Display the current cipher alphabet in the message line."
(interactive)
- (message
+ (message "%s"
(mapconcat (lambda (a)
(concat
(char-to-string (car a))
(replace-match ">" nil nil))
(decipher-read-alphabet)
(while (setq mapping (pop alphabet))
- (or (equal ?\ (cdr mapping))
+ (or (equal ?\s (cdr mapping))
(decipher-set-map (cdr mapping) (car mapping))))))
(setq decipher-undo-list nil
decipher-undo-list-size 0)
(while (>= plain-char ?a)
(backward-char)
(push (cons plain-char (following-char)) decipher-alphabet)
- (decf plain-char)))))
+ (cl-decf plain-char)))))
;;;===================================================================
;;; Analyzing ciphertext:
1 1 1 2 1 1 2 5 7
This says that X comes before D once, and after B once. X begins 5
words, and ends 3 words (`*' represents a space). X comes before 8
-different letters, after 7 differerent letters, and is next to a total
+different letters, after 7 different letters, and is next to a total
of 11 different letters. It occurs 14 times, making up 9% of the
ciphertext."
(interactive (list (upcase (following-char))))
(decipher-analyze)
(let (start end)
- (save-excursion
- (set-buffer (decipher-stats-buffer))
+ (with-current-buffer (decipher-stats-buffer)
(goto-char (point-min))
(or (re-search-forward (format "^%c: " cipher-char) nil t)
- (error "Character `%c' is not used in ciphertext." cipher-char))
+ (error "Character `%c' is not used in ciphertext" cipher-char))
(forward-line -1)
(setq start (point))
(forward-line 3)
END-REGEXP matches the line after that which ends the display.
The ending line is included in the display unless it is blank."
(let (start end)
- (save-excursion
- (set-buffer (decipher-stats-buffer))
+ (with-current-buffer (decipher-stats-buffer)
(goto-char (point-min))
(re-search-forward start-regexp)
(beginning-of-line)
a space.
See `decipher-loop-no-breaks' if you do not care about word divisions."
- (let ((decipher-char ?\ )
- (decipher--loop-prev-char ?\ ))
+ (let ((decipher-char ?\s)
+ (decipher--loop-prev-char ?\s))
(save-excursion
(goto-char (point-min))
(funcall func) ;Space marks beginning of first word
(while (not (eolp))
(setq decipher-char (upcase (following-char)))
(or (and (>= decipher-char ?A) (<= decipher-char ?Z))
- (setq decipher-char ?\ ))
- (or (and (equal decipher-char ?\ )
- (equal decipher--loop-prev-char ?\ ))
+ (setq decipher-char ?\s))
+ (or (and (equal decipher-char ?\s)
+ (equal decipher--loop-prev-char ?\s))
(funcall func))
(setq decipher--loop-prev-char decipher-char)
(forward-char))
- (or (equal decipher-char ?\ )
+ (or (equal decipher-char ?\s)
(progn
- (setq decipher-char ?\ ;
- decipher--loop-prev-char ?\ )
+ (setq decipher-char ?\s
+ decipher--loop-prev-char ?\s)
(funcall func)))))))
(defun decipher-loop-no-breaks (func)
(while temp-list
(insert (caar temp-list)
(format "%4d%3d%% "
- (cadar temp-list)
- (/ (* 100 (cadar temp-list)) total)))
+ (cl-cadar temp-list)
+ (/ (* 100 (cl-cadar temp-list)) total)))
(setq temp-list (nthcdr 4 temp-list)))
(insert ?\n)
(setq freq-list (cdr freq-list)
;; A vector of 26 integers, counting the number of occurrences
;; of the corresponding characters.
(setq decipher--digram (format "%c%c" decipher--prev-char decipher-char))
- (incf (cdr (or (assoc decipher--digram decipher--digram-list)
+ (cl-incf (cdr (or (assoc decipher--digram decipher--digram-list)
(car (push (cons decipher--digram 0)
decipher--digram-list)))))
(and (>= decipher--prev-char ?A)
- (incf (aref (aref decipher--before (- decipher--prev-char ?A))
- (if (equal decipher-char ?\ )
+ (cl-incf (aref (aref decipher--before (- decipher--prev-char ?A))
+ (if (equal decipher-char ?\s)
26
(- decipher-char ?A)))))
(and (>= decipher-char ?A)
- (incf (aref decipher--freqs (- decipher-char ?A)))
- (incf (aref (aref decipher--after (- decipher-char ?A))
- (if (equal decipher--prev-char ?\ )
+ (cl-incf (aref decipher--freqs (- decipher-char ?A)))
+ (cl-incf (aref (aref decipher--after (- decipher-char ?A))
+ (if (equal decipher--prev-char ?\s)
26
(- decipher--prev-char ?A)))))
(setq decipher--prev-char decipher-char))
(let ((total 0))
(concat
(mapconcat (lambda (x)
- (cond ((> x 99) (incf total) "XX")
- ((> x 0) (incf total) (format "%2d" x))
+ (cond ((> x 99) (cl-incf total) "XX")
+ ((> x 0) (cl-incf total) (format "%2d" x))
(t " ")))
counts
"")
;; We do not include spaces (word divisions) in this count.
(let ((total 0)
(i 26))
- (while (>= (decf i) 0)
+ (while (>= (cl-decf i) 0)
(if (or (> (aref before-count i) 0)
(> (aref after-count i) 0))
- (incf total)))
+ (cl-incf total)))
total))
(defun decipher-analyze-buffer ()
"Perform frequency analysis and store results in statistics buffer.
Creates the statistics buffer if it doesn't exist."
- (let ((decipher--prev-char (if decipher-ignore-spaces ?\ ?\*))
+ (let ((decipher--prev-char (if decipher-ignore-spaces ?\s ?\*))
(decipher--before (make-vector 26 nil))
(decipher--after (make-vector 26 nil))
(decipher--freqs (make-vector 26 0))
decipher--digram decipher--digram-list freq-list)
(message "Scanning buffer...")
(let ((i 26))
- (while (>= (decf i) 0)
+ (while (>= (cl-decf i) 0)
(aset decipher--before i (make-vector 27 0))
(aset decipher--after i (make-vector 27 0))))
(if decipher-ignore-spaces
(decipher-loop-no-breaks 'decipher--analyze)
;; The first character of ciphertext was marked as following a space:
(let ((i 26))
- (while (>= (decf i) 0)
+ (while (>= (cl-decf i) 0)
(aset (aref decipher--after i) 26 0))))
(decipher-loop-with-breaks 'decipher--analyze))
(message "Processing results...")
;; of times it occurs, and DIFFERENT is the number of different
;; letters it appears next to.
(let ((i 26))
- (while (>= (decf i) 0)
+ (while (>= (cl-decf i) 0)
(setq freq-list
(cons (list (+ i ?A)
(aref decipher--freqs i)
(aref decipher--after i)))
freq-list)
total-chars (+ total-chars (aref decipher--freqs i)))))
- (save-excursion
- ;; Switch to statistics buffer, creating it if necessary:
- (set-buffer (decipher-stats-buffer t))
+ ;; Switch to statistics buffer, creating it if necessary:
+ (with-current-buffer (decipher-stats-buffer t)
;; This can't happen, but it never hurts to double-check:
(or (eq major-mode 'decipher-stats-mode)
(error "Buffer %s is not in Decipher-Stats mode" (buffer-name)))
(insert ?\n)
;; Display frequency counts for letters in order of frequency:
(setq freq-list (sort freq-list
- (lambda (a b) (> (second a) (second b)))))
+ (lambda (a b) (> (cl-second a) (cl-second b)))))
(decipher-insert-frequency-counts freq-list total-chars)
;; Display letters in order of frequency:
(insert ?\n (mapconcat (lambda (a) (char-to-string (car a)))
;; Display adjacency list for each letter, sorted in descending
;; order of the number of adjacent letters:
(setq freq-list (sort freq-list
- (lambda (a b) (> (third a) (third b)))))
+ (lambda (a b) (> (cl-third a) (cl-third b)))))
(let ((temp-list freq-list)
entry i)
(while (setq entry (pop temp-list))
- (if (equal 0 (second entry))
+ (if (equal 0 (cl-second entry))
nil ;This letter was not used
(setq i (- (car entry) ?A))
(insert ?\n " "
(car entry)
": 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 *"
(format "%4d %4d %3d%%\n "
- (third entry) (second entry)
- (/ (* 100 (second entry)) total-chars))
+ (cl-third entry) (cl-second entry)
+ (/ (* 100 (cl-second entry)) total-chars))
(decipher--digram-counts (aref decipher--after i)) ?\n))))
(setq buffer-read-only t)
(set-buffer-modified-p nil)
major-mode 'decipher-stats-mode
mode-name "Decipher-Stats")
(use-local-map decipher-stats-mode-map)
- (run-hooks 'decipher-stats-mode-hook))
+ (run-mode-hooks 'decipher-stats-mode-hook))
(put 'decipher-stats-mode 'mode-class 'special)
;;--------------------------------------------------------------------
;; See if decipher-stats-buffer exists:
((and (bufferp decipher-stats-buffer)
(buffer-name decipher-stats-buffer))
- (or (save-excursion
- (set-buffer decipher-stats-buffer)
+ (or (with-current-buffer decipher-stats-buffer
(eq major-mode 'decipher-stats-mode))
(error "Buffer %s is not in Decipher-Stats mode"
(buffer-name decipher-stats-buffer)))
;; We just lost track of the statistics buffer:
(get-buffer stats-name)
(generate-new-buffer stats-name))))
- (save-excursion
- (set-buffer decipher-stats-buffer)
+ (with-current-buffer decipher-stats-buffer
(decipher-stats-mode))
decipher-stats-buffer)
;; Give up:
(provide 'decipher)
-;;;(defun decipher-show-undo-list ()
-;;; "Display the undo list (for debugging purposes)."
-;;; (interactive)
-;;; (with-output-to-temp-buffer "*Decipher Undo*"
-;;; (let ((undo-list decipher-undo-list)
-;;; undo-rec undo-map)
-;;; (save-excursion
-;;; (set-buffer "*Decipher Undo*")
-;;; (while (setq undo-rec (pop undo-list))
-;;; (or (consp (car undo-rec))
-;;; (setq undo-rec (list undo-rec)))
-;;; (insert ?\()
-;;; (while (setq undo-map (pop undo-rec))
-;;; (insert (cdr undo-map) (car undo-map) ?\ ))
-;;; (delete-backward-char 1)
-;;; (insert ")\n"))))))
+;;(defun decipher-show-undo-list ()
+;; "Display the undo list (for debugging purposes)."
+;; (interactive)
+;; (with-output-to-temp-buffer "*Decipher Undo*"
+;; (let ((undo-list decipher-undo-list)
+;; undo-rec undo-map)
+;; (with-current-buffer "*Decipher Undo*"
+;; (while (setq undo-rec (pop undo-list))
+;; (or (consp (car undo-rec))
+;; (setq undo-rec (list undo-rec)))
+;; (insert ?\()
+;; (while (setq undo-map (pop undo-rec))
+;; (insert (cdr undo-map) (car undo-map) ?\s))
+;; (delete-char -1)
+;; (insert ")\n"))))))
;;; decipher.el ends here