;;; decipher.el --- cryptanalyze monoalphabetic substitution ciphers
;;
-;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1995-1996, 2001-2015 Free Software Foundation, Inc.
;;
;; Author: Christopher J. Madsen <chris_madsen@geocities.com>
;; Keywords: games
;;; 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.
+ "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
(defcustom decipher-ignore-spaces nil
- "*Non-nil means to ignore spaces and punctuation when counting digrams.
+ "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."
("^)\\([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)
- (define-key decipher-mode-map [remap undo] 'decipher-undo)
- (define-key decipher-mode-map [remap advertised-undo] 'decipher-undo)
- (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
(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)))
(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))
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 ?\s
- decipher--loop-prev-char ?\ )
+ 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)
;; 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"))))))
-
-;; arch-tag: 8f094d88-ffe1-4f99-afe3-a5e81dd939d9
+;;(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