Simulated annealing code for crypto example from uni.

eg_simulated_annealing.lisp

;;; Code for the Simulated Annealing Cryptanalysis example.
;;;
;;; Code Author: Russell Edson
;;; Date: 28/05/2015

;; The letters for the key alphabet (ie. A-Z.)
(defconstant +key-alphabet+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ")

;; Letter frequencies (from "Cryptological Mathematics", R.E. Lewand 2000)
(defconstant +english-letter-frequencies+
  (mapcar (lambda (n) (/ n 100.0d0))
          (list 8.167 1.492 2.782 4.253 12.702 2.228 2.015 6.094 6.966 0.153
                0.772 4.025 2.406 6.749  7.507 1.929 0.095 5.987 6.327 9.056
                2.758 0.978 2.361 0.150  1.974 0.074)))

(defun make-decipher-from-key (key)
  "Takes a key, and returns a dispatch function for the deciphering."
  (lambda (letter)
    (let* ((upcase-letter (char-upcase letter))
           (alphabet-position (position upcase-letter +key-alphabet+)))
        (elt key alphabet-position))))
      
(defun random-pick (list)
  "Returns a random element from the given list."
  (elt list (random (length list))))

(defun permutation (list)
  "Returns a permutation of a given list. (Recursive.)"
  (if (null list)
      nil
      (let ((random-element (random-pick list)))
        (cons random-element
              (permutation (remove random-element list))))))

(defun random-key ()
  "Returns a new random key."
  (coerce (permutation (coerce +key-alphabet+ 'list)) 'string))

(defun ciphertext->plaintext (ciphertext key)
  "Converts ciphertext to plaintext using the given key."
  (let ((text-letters (coerce ciphertext 'list))
        (decipher (make-decipher-from-key key)))
    (coerce (mapcar decipher text-letters) 'string)))

(defun key-2change (key)
  "Returns a key from the 2-change neighbourhood of the given key."
  (let ((new-key (copy-seq key))
        (i (random (length key)))
        (j (random (length key))))
    (if (= i j) (setf j (mod (1+ j) (length key))))
    (rotatef (elt new-key i) (elt new-key j))
    new-key))

(defun letter-frequency (text)
  "Returns a list of the frequencies of the letters in the given text."
  (let ((total-letters (length text)))
    (loop for letter in (coerce +key-alphabet+ 'list)
       collecting (/ (count letter text) total-letters))))

(defun square-distance (x y)
  "Returns the square-distance |x-y|^2 for lists x and y."
  (let ((x-y (loop for xi in x for yi in y collecting (- xi yi))))
    (reduce #'+ (mapcar (lambda (n) (* n n)) x-y))))
  
;; TODO
;; At the moment, we compare the distributions with a least-squares
;; sort of method. We want a better method than this though.
(defun fitness (ciphertext key)
  "Determines the fitness of the key for the given ciphertext."
  (let* ((deciphered-text (ciphertext->plaintext ciphertext key))
         (letter-frequencies (letter-frequency deciphered-text)))
    (exp (- (square-distance +english-letter-frequencies+
                             letter-frequencies)))))

(defun acceptance-function (df temperature)
  "Returns the probability that we accept the new key in the annealing."
  (if (<= df 0)
      1.0d0
      (exp (/ (- df) temperature))))

(defun decipher-with-annealing (ciphertext initial-temperature end-temperature)
  "Approximates the correct key for the ciphertext using simulated annealing."
  (let* ((best-key (random-key))
         (best-fitness (fitness ciphertext best-key)))
    (do ((current-key best-key)
         (current-fitness best-fitness)
         (temperature initial-temperature))
        ((< temperature end-temperature)
         (list best-key
               (ciphertext->plaintext ciphertext best-key)))
      (let* ((next-key (key-2change current-key))
             (next-fitness (fitness ciphertext next-key))
             (df (- current-fitness next-fitness))
             (acceptance-probability (acceptance-function df temperature)))
        (when (< (random 1.0d0) acceptance-probability)
          (setf current-key next-key)
          (setf current-fitness next-fitness)
          (when (> current-fitness best-fitness)
            (format t "key:~a  fitness:~a~%" current-key current-fitness)
            (setf best-key current-key)
            (setf best-fitness current-fitness)))
        (setf temperature (* temperature 0.99d0))))))