;;; -*- Mode: Lisp -*-
;;;
;;; $Header: /home/gene/library/website/docsrc/vig/RCS/vigenere.lisp,v 395.1 2008/04/20 17:25:48 gene Exp $
;;;
;;; Copyright (C) 2004  Gene Michael Stover.  All rights reserved.
;;; 
;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of version 2.1 of the GNU
;;; Lesser General Public License as published by the Free
;;; Software Foundation.
;;; 
;;; This library 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 Lesser General Public License for more
;;; details.
;;; 
;;; You should have received a copy of the GNU Lesser General
;;; Public License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;; Boston, MA 02111-1307 USA
;;;

(defvar *vigenere-alphanum*
  (list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
	#\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 #\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)
  "Alphabet of upper-case letters, lower-case letters, & digits.")

(defvar *vigenere-simple-alphabet*
  (list #\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)
  "Alphabet of upper-case letters & digits.  This is the minimalist
alphabet that old cryptology books use.")

(defvar *vigenere-octetabet* (loop for i from 0 to 255 collect i)
  "Alphabet of all unsigned, 8-bit values.")

(defvar *vigenere-default-alphabet* *vigenere-alphanum*
  "The alphabet to use for encryption & decryption when one is not
specified.")

(defun make-xfrm (letter alphabet)
  "Return a hash table that encrypts characters using the alphabet
generated from ALPHABET, shifted by LETTER.  ALPHABET may be any
sequence, as long as we can use ELT on it."
  (declare (type atom letter) (type sequence alphabet))
  (do ((ht (make-hash-table :test #'equal)                                )
       (i       (position letter alphabet)  (mod (1+ i) (length alphabet)))
       (j                                0                          (1+ j)))
      ((>= j (length alphabet))         ht)
      (setf (gethash (elt alphabet j) ht) (elt alphabet i))))

(defun invert-xfrm (xfrm)
  "Given XFRM which encrypts, return a new XFRM which decrypts."
  (declare (type hash-table xfrm))
  (let ((xfrm2 (make-hash-table :test #'equal)))
    (maphash #'(lambda (plaintext ciphertext)
		 (setf (gethash ciphertext xfrm2) plaintext))
	     xfrm)
    xfrm2))

(defun print-xfrm (xfrm strm)
  "Print XFRM to STRM.  XFRM was created by MAKE-XFRM."
  (declare (type hash-table xfrm))
  (format strm "~&#<xfrm")
  (maphash #'(lambda (k v) (format strm "~&    ~S" (cons k v))) xfrm)
  (format strm ">")
  xfrm)
    
(defun make-alphabets (key alphabet)
  "Return a circular list of transformation alphabets.  Each transformation
alphabet is a vector of characters from ALPHABET."
  (let ((lst (loop for i from 0
		   while (< i (length key))
		   collect (make-xfrm (elt key i) alphabet))))
    (setf (cdr (last lst)) lst)         ; Make it a circular list.
    lst))

(defun inverse-alphabets (key alphabet)
  "Return a circular list of transformation alphabets.  Each transformation
alphabet is a vector of characters from ALPHABET."
  (let ((lst (loop for i from 0
		   while (< i (length key))
		   collect (invert-xfrm (make-xfrm (elt key i) alphabet)))))
    (setf (cdr (last lst)) lst)         ; Make it a circular list.
    lst))

(defun vigenere-loop (itext xfrm)
  (labels ((xchar (c a)
		  "Transform character C via the first alphabet in A, which
                   is a list of alphabets."
		  (declare (type atom c) (type list a))
		  (gethash c (first a) c)))
    (let ((otext
	   ;; In this loop, itx is the source text as a list;
	   ;; otx is result text, as a reversed list.
	   (do ((itx (coerce itext 'list)  (rest itx))
		(x                   xfrm  (cdr x))
		(otx                   ()  (cons (xchar (first itx) x) otx)))
	       ((endp itx)          (coerce (nreverse otx) (type-of itext))))))
      ;; Break the circular list to give the garbage collector a helping hand.
      (setf (cdr xfrm) nil)
      otext)))

(defun vigenere-encrypt (plaintext
			 key
			 &optional
			 (alphabet *vigenere-default-alphabet*))
  (vigenere-loop plaintext (make-alphabets key alphabet)))

(defun vigenere-decrypt (ciphertext
			 key
			 &optional
			 (alphabet *vigenere-default-alphabet*))
  (vigenere-loop ciphertext (inverse-alphabets key alphabet)))

(defun test0000 ()
  "Null test.  Always succeeds."
  'test0000)

(defun test0001 ()
  "Checks that we encrypt the same as an example from Seberry &
Pieprzyk."
  (let* ((input "INDIVIDUALCHARACTER")
	 (expect "PBVBCWVNHZUAHFSVASJ")
	 (result (vigenere-encrypt input "HOST" *vigenere-simple-alphabet*)))
    (unless (equal result expect)
      (format t "~&~A: Got ~S.  Expected ~S." 'test0000 result expect))
    (equal result expect)))

(defun test0002 ()
  "Check that decrypting a message encrypted with a key gives the
plaintext.  Uses hard-coded plaintext & key."
  (let* ((key "theleeofthekeyisthestone")
	 (plaintext0 "Vigenere wasn't a Legionaire.  He was a Frigidaire.")
	 (ciphertext (vigenere-encrypt plaintext0 key))
	 (plaintext1 (vigenere-decrypt ciphertext key)))
    (unless (equal plaintext0 plaintext1)
      (format t "~&~A: Decryption returned ~S.  Expected ~S." 'test0002
	      plaintext0 plaintext1))
    (equal plaintext0 plaintext1)))

;;; --- end of file ---