;;; -*- Mode:LISP; Package:(CRYPT GLOBAL); Base:10; Readtable:ZL -*-

;; This program implements the
;; Proposed Federal Information Processing
;; Data Encryption Standard.
;; See Federal Register, March 17, 1975 (40FR12134)

(defmacro define-char-array (name dimlist &optional contents)
  (let ((v (intern (string-append "*" name "*")))
	(l (mapcar #'(lambda (ignore) (gentemp "i")) dimlist)))
    `(progn 'compile
	    (defparameter ,v (char-array-init ',dimlist ',contents))
	    (defmacro ,name ,l (list 'aref ',v ,@l)))))


(defun char-array-init (dimlist contents)
  (let ((a (if (not (numberp (car dimlist)))
	       (make-array (length contents))
	     (make-array dimlist))))
    (fillarray a (if (not contents) (list 0) contents))
    a))

;; Initial permutation,

(define-char-array IP (NIL)
  (58 50 42 34 26 18 10  2 
   60 52 44 36 28 20 12  4 
   62 54 46 38 30 22 14  6 
   64 56 48 40 32 24 16  8 
   57 49 41 33 25 17  9  1 
   59 51 43 35 27 19 11  3 
   61 53 45 37 29 21 13  5 
   63 55 47 39 31 23 15  7))



;; Final permutation, FP = IP^(-1)

(define-char-array FP (NIL)
  (40  8 48 16 56 24 64 32
   39  7 47 15 55 23 63 31 
   38  6 46 14 54 22 62 30 
   37  5 45 13 53 21 61 29 
   36  4 44 12 52 20 60 28 
   35  3 43 11 51 19 59 27 
   34  2 42 10 50 18 58 26 
   33  1 41  9 49 17 57 25))

;; Permuted-choice 1 from the key bits
;; to yield C and D.
;; Note that bits 8,16... are left out:
;; They are intended for a parity check.

(define-char-array PC1_C (NIL)
  (57 49 41 33 25 17  9 
    1 58 50 42 34 26 18 
    10  2 59 51 43 35 27 
    19 11  3 60 52 44 36))


(define-char-array  PC1_D (NIL)
  (63 55 47 39 31 23 15 
    7 62 54 46 38 30 22 
   14  6 61 53 45 37 29 
   21 13  5 28 20 12  4))


;; Sequence of shifts used for the key schedule.

(define-char-array shifts (NIL)
  (1 1 2 2 2 2 2 2 1 2 2 2 2 2 2 1))

;; Permuted-choice 2, to pick out the bits from
;; the CD array that generate the key schedule.

(define-char-array  PC2_C (NIL)
  (14 17 11 24  1  5 
    3 28 15  6 21 10 
   23 19 12  4 26  8 
   16  7 27 20 13  2))


(define-char-array  PC2_D (NIL)
  (41 52 31 37 47 55 
   30 40 51 45 33 48 
   44 49 39 56 34 53 
   46 42 50 36 29 32))

;; The C and D arrays used to calculate the key schedule.

(define-char-array C (28))
(define-char-array D (28))

;; The key schedule.
;; Generated from the key.

(define-char-array ks (16 48))

;; Set up the key schedule from the key.

(defun setkey (key)
  (macrolet ((key (index) `(aref key ,index)))
    ;; First, generate C and D by permuting
    ;; the key.  The low order bit of each
    ;; 8-bit char is not used, so C and D are only 28
    ;; bits apiece.
    (do ((i 0 (1+ i)))
	((= i 28))
      (setf (c i) (key (1- (pc1_c i))))
      (setf (d i) (key (1- (pc1_d i)))))
    ;; To generate Ki, rotate C and D according
    ;; to schedule and pick up a permutation
    ;; using PC2.
    (do ((i 0 (1+ i)))
	((= i 16))
      ;; rotate.
      (do ((k 0 (1+ k))
	   (temp))
	  ((not (< k (shifts i))))
	(setq temp (c 0))
	(do ((j 0 (1+ j)))
	    ((not (< j (- 28 1))))
	  (setf (c j) (c (1+ j))))
	(setf (c 27) temp)
	(setq temp (d 0))
	(do ((j 0 (1+ j)))   
	    ((not (< j (- 28 1))))
	  (setf (d j) (d (1+ j))))
	(setf (d 27) temp))
      ;; get Ki. Note C and D are concatenated.
      (do ((j 0 (1+ j)))
	  ((= j 24))          
	(setf (ks i j) (c (- (pc2_c j) 1)))
	(setf (ks i (+ j 24)) (d (- (pc2_d j) 28 1)))))))


;; The E bit-selection table.

(define-char-array EB (48))

(define-char-array e (NIL)
  (32  1  2  3  4  5 
    4  5  6  7  8  9 
    8  9 10 11 12 13 
   12 13 14 15 16 17 
   16 17 18 19 20 21 
   20 21 22 23 24 25 
   24 25 26 27 28 29 
   28 29 30 31 32  1))



;; The 8 selection functions.
;; For some reason, they give a 0-origin
;; index, unlike everything else.

(define-char-array S (8 64)
  (14  4 13  1  2 15 11  8  3 10  6 12  5  9  0  7 
    0 15  7  4 14  2 13  1 10  6 12 11  9  5  3  8 
    4  1 14  8 13  6  2 11 15 12  9  7  3 10  5  0 
   15 12  8  2  4  9  1  7  5 11  3 14 10  0  6 13 

   15  1  8 14  6 11  3  4  9  7  2 13 12  0  5 10 
    3 13  4  7 15  2  8 14 12  0  1 10  6  9 11  5 
    0 14  7 11 10  4 13  1  5  8 12  6  9  3  2 15 
   13  8 10  1  3 15  4  2 11  6  7 12  0  5 14  9 
   
   10  0  9 14  6  3 15  5  1 13 12  7 11  4  2  8 
   13  7  0  9  3  4  6 10  2  8  5 14 12 11 15  1 
   13  6  4  9  8 15  3  0 11  1  2 12  5 10 14  7 
    1 10 13  0  6  9  8  7  4 15 14  3 11  5  2 12 
   
    7 13 14  3  0  6  9 10  1  2  8  5 11 12  4 15 
   13  8 11  5  6 15  0  3  4  7  2 12  1 10 14  9 
   10  6  9  0 12 11  7 13 15  1  3 14  5  2  8  4 
    3 15  0  6 10  1 13  8  9  4  5 11 12  7  2 14 
   
    2 12  4  1  7 10 11  6  8  5  3 15 13  0 14  9 
   14 11  2 12  4  7 13  1  5  0 15 10  3  9  8  6 
    4  2  1 11 10 13  7  8 15  9 12  5  6  3  0 14 
   11  8 12  7  1 14  2 13  6 15  0  9 10  4  5  3 
   
   12  1 10 15  9  2  6  8  0 13  3  4 14  7  5 11 
   10 15  4  2  7 12  9  5  6  1 13 14  0 11  3  8 
    9 14 15  5  2  8 12  3  7  0  4 10  1 13 11  6 
    4  3  2 12  9  5 15 10 11 14  1  7  6  0  8 13 
   
    4 11  2 14 15  0  8 13  3 12  9  7  5 10  6  1 
   13  0 11  7  4  9  1 10 14  3  5 12  2 15  8  6 
    1  4 11 13 12  3  7 14 10 15  6  8  0  5  9  2 
    6 11 13  8  1  4 10  7  9  5  0 15 14  2  3 12 
   
   13  2  8  4  6 15 11  1 10  9  3 14  5  0 12  7 
    1 15 13  8 10  3  7  4 12  5  6 11  0 14  9  2 
    7 11  4  1  9 12 14  2  0  6 10 13 15  3  5  8 
    2  1 14  7  4 10  8 13 15 12  9  0  3  5  6 11 ))



;; P is a permutation on the selected combination
;; of the current L and key.

(define-char-array p (nil)
  (16  7 20 21 
   29 12 28 17 
    1 15 23 26 
    5 18 31 10 
    2  8 24 14 
   32 27  3  9 
   19 13 30  6 
   22 11  4 25))



;; The current block, divided into 2 halves.

(define-char-array l (32))
(define-char-array r (32))
(define-char-array templ (32))
(define-char-array f (32))


;; The combination of the key and the input, before selection.

(define-char-array pres (48))




;; The payoff: encrypt a block.


(defun encrypt (block edflag &aux temp i)
  (macrolet ((block (index) `(aref block ,index)))
    (dotimes (j 64)
      (setf (l j) (block (- (ip j) 1))))
    ;; Perform an encryption operation 16 times.
    (dotimes (ii 16)
      ;; Set direction
      (if edflag (setq i (- 15 ii)) (setq i ii))
      ;; Save the R array,
      ;; which will be the new L.
      (dotimes (j 32)
	(setf (templ j) (r j)))
      ;; Expand R to 48 bits using the E selector;
      ;; exclusive-or with the current key bits.
      (dotimes (j 48)
	(setf (pres j) (logxor (r (- (e j) 1))
			       (ks i j))))
      ;; The pre-select bits are now considered
      ;; in 8 groups of 6 bits each.
      ;; The 8 selection functions map these
      ;; 6-bit quantities into 4-bit quantities
      ;; and the results permuted
      ;; to make an f(R, K).
      ;; The indexing into the selection functions
      ;; is peculiar; it could be simplified by
      ;; rewriting the tables.
      (dotimes (j 8)
	(setq temp (* 6 j))
	(setq k (s j (+ (ash (pres (+ temp 0)) 5)
			(ash (pres (+ temp 1)) 3)
			(ash (pres (+ temp 2)) 2)
			(ash (pres (+ temp 3)) 1)
			(ash (pres (+ temp 4)) 0)
			(ash (pres (+ temp 5)) 4))))
	(setq temp (* 4 j))
	(setf (f (+ temp 0)) (logand (ash k -3) 1))
	(setf (f (+ temp 1)) (logand (ash k -2) 1))
	(setf (f (+ temp 2)) (logand (ash k -1) 1))
	(setf (f (+ temp 3)) (logand (ash k -0) 1)))
      ;; The new R is L ^ f(R, K).
      ;; The f here has to be permuted first, though.
      (dotimes (j 32)
	(setf (r j) (logxor (l j) (f (- (p j) 1)))))
      ;; Finally, the new L (the original R)
      ;; is copied back.
      (dotimes (j 32)
	(setf (l j) (templ j))))
    ;; The output L and R are reversed.
    (dotimes (j 32)
      (setq temp (l j))
      (setf (l j) (r j))
      (setf (r j) temp))
    ;; The final output
    ;; gets the inverse permutation of the very original.
    (dotimes (j 64)
      (setf (block j) (l (- (fp j) 1))))))


(define-char-array bblock (65))
(define-char-array iobuf (16))

(defun crypt (pw salt)
  (macrolet ((pw (index) `(aref pw ,index))
	     (salt (index) `(aref salt ,index)))
    (dotimes (i 66)
      (setf (block i) 0))

	for(i=0; i<66; i++)
		block[i] = 0;
	for(i=0; (c= *pw) && i<64; pw++){
		for(j=0; j<7; j++, i++)
			block[i] = (c>>(6-j)) & 01;
		i++;
	}

	(setkey *bblock*)
	
	for(i=0; i<66; i++)
		block[i] = 0;

	for(i=0;i<48;i++)
		E[i] = e[i];

	for(i=0;i<2;i++){
		c = *salt++;
		iobuf[i] = c;
		if(c>'Z') c -= 6;
		if(c>'9') c -= 7;
		c -= '.';
		for(j=0;j<6;j++){
			if((c>>j) & 01){
				temp = E[6*i+j];
				E[6*i+j] = E[6*i+j+24];
				E[6*i+j+24] = temp;
				}
			}
		}
	
	for(i=0; i<25; i++)
		encrypt(block,0);
	
	for(i=0; i<11; i++){
		c = 0;
		for(j=0; j<6; j++){
			c <<= 1;
			c |= block[6*i+j];
			}
		c += '.';
		if(c>'9') c += 7;
		if(c>'Z') c += 6;
		iobuf[i+2] = c;
	}
	iobuf[i+2] = 0;
	if(iobuf[1]==0)
		iobuf[1] = iobuf[0];
	return(iobuf);
}