; Does encryption and decryption of the stream/keyed decimation cipher

;

; Functions:

; (plain-char->num c) convert char c into its number, don't pass not alphabetic chars

; (num->cipher0char n) converts n into a captial letter

; (plain-text->nums s) converts string s into a list of nums for the alpabetic chars in s

; (nums->cipher-text l) converts list l of numbers into a string of letters group into fives

; (nums->plain-text l) as above but doesn't insert spaces

;

; (build-mono-key s) uses keyword string s to make a mono key using the transposed mixed sequence method

; (random-mono-key) produces a random mono key

; (inverse-mono-key k) inverses a mono key

; (encrypt text mono-key key) encrypts the string text using the mono-key ass produced by the above functions and the keyword string key

; (decrypt text mono-key key) same as encrypt but decrypts.  Pass the same key values.

;

; Author:

; Jeff Walker

;         stream encrypt/decrypt and other high level functions

;

; Scott Trimmer

;         keyed decimation



(require-library "functio.ss")



;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Following code by Jeff Walker



;; Text is stored as strings, use "quotes". Internally text is stored

;; in lists of numbers.  a=1, b=2, ..., z=26=0(mod 26)

;; Remeber that 'a is not the letter a, you need #\a.  Special codes include #\space and #\newline



(define ALPHA_SIZE 26)

(define a_NUM (char->integer #\a))



;; Takes a char and gives the number equivalent, ignores case

;; Note that it give z=26

(define plain-char->num

  (lambda (char)

    (if (not (char-alphabetic? char))

        (error 'plaintext->num "parameter is not an alphabetic char")

        (add1 (- (char->integer (char-downcase char)) a_NUM)))))



;; Takes a number and returns its capitol equivalent

(define num->cipher-char

  (lambda (num)

    (char-upcase (integer->char (+ (modulo (sub1 num) ALPHA_SIZE) a_NUM)))))



;; Convert strings to lists of char nums, drops none alphabetic characters

(define plain-text->nums

  (lambda (string)

    (map plain-char->num (filter char-alphabetic? (string->list string)))))



;; Converts a list of nums to a string of chars (groups of 5)

(define nums->cipher-text

  (lambda (nums)

    (letrec ((list (map num->cipher-char nums))

             (insert-spaces

                  (lambda (l n)

                    (if (null? l)

                        l

                        (let ((rest (cons (car l) (insert-spaces (cdr l) (modulo (add1 n) 5)))))

                          (if (= n 4)

                              (cons #\space rest)

                              rest))))))

      (list->string (insert-spaces list -1)))))



;; Utility method for when you want to just see the letters (no spaces)

(define nums->plain-text

  (lambda (nums)

    (list->string (map char-downcase (map num->cipher-char nums)))))

;; Now that one can read text we need the ability to create mono keys from this.

;; Mono keys are stored as 26 place vectors, where a encodes to the first item in the vector and so on.

;; It is also possible to take one of these keys and make a function on numbers which acts.



(define ALPHABET '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26))



;; pulls out every n's letter, always taking the first one.

(define simple-sieve

  (lambda (list n)

    (letrec ((help

              (lambda (list c n)

                (if (null? list)

                    list

                    (let ((rest (help (cdr list) (modulo (add1 c) n) n)))

                      (if (= c 0)

                          (cons (car list) rest)

                          rest))))))

      (help list 0 n))))



;; takes a string and builds a mono key from it

;; This uses the transposed mixed sequence to form the key

(define build-mono-key

  (lambda (string)

    (letrec ((no-repeat

               (foldl (lambda (element so-far)

                        (if (not (member element so-far))

                            (append so-far (list element))

                            so-far))

                      '()

                      (plain-text->nums string)))

             (size (length no-repeat))

             (unfinished-key (append no-repeat (filter (lambda (i) (not (member i no-repeat))) ALPHABET)))

             (help

              (lambda (list n)

                (if (or (null? list) (= n 0))

                    '()

                    (append (simple-sieve list size) (help (cdr list) (sub1 n)))))))

      (list->vector (help unfinished-key size)))))



(define random-mono-key

  (lambda ()

    (letrec ((key (list->vector ALPHABET))

             (help

              (lambda (place key)

                (if (null? place)

                    key

                    (let ((swap-place (random (car place)))

                          (current (vector-ref key (sub1 (car place)))))

                      (vector-set! key (sub1 (car place)) (vector-ref key swap-place))

                      (vector-set! key swap-place current)

                      (help (cdr place) key)

                      )))))

      (help (reverse (upto 26)) key))))



(define inverse-mono-key

  (lambda (key)

    (letrec ((new-key (make-vector 26))

             (help

              (lambda (place)

                (if (null? place)

                    new-key

                    (begin

                      (vector-set! new-key (modulo (sub1 (vector-ref key (sub1 (car place)))) ALPHA_SIZE) (car place))

                      (help (cdr place)))))))

      (help (upto 26)))))



(define factory-mono-func

  (lambda (mono-key)

    (lambda (num)

      (vector-ref mono-key (modulo (sub1 num) ALPHA_SIZE)))))



;; Allows you to create a stream encrypt function, remeber that each letter you encrypt with it changes the encrypt function

(define make-stream-encrypt

  (lambda (mono-key-func keyword)

    (letrec ((key (list->vector (plain-text->nums keyword)))

             (key-length (vector-length key))

             (key-place -1)

             (wheel-pos 1)) ;; wheel starts on a which is 1, not zero based!

      (lambda (num)

        (set! key-place (modulo (add1 key-place) key-length)) 

        (set! wheel-pos (modulo (+ wheel-pos num (vector-ref key key-place)) ALPHA_SIZE))

        (mono-key-func wheel-pos)))))



(define make-stream-decrypt

  (lambda (mono-key-func keyword)

    (letrec ((key (list->vector (plain-text->nums keyword)))

             (key-length (vector-length key))

             (key-place -1)

             (wheel-pos 1)) ;; wheel starts on a which is 1, not zero based!

      (lambda (num)

        (set! key-place (modulo (add1 key-place) key-length))

        (letrec ((plain-letter (modulo (- (mono-key-func num) (vector-ref key key-place) wheel-pos) ALPHA_SIZE)))

          (set! wheel-pos (mono-key-func num))

          plain-letter

          )))))



(define encrypt

  (lambda (text mono-key key)

    (letrec ((s (make-stream-encrypt (factory-mono-func mono-key) key))

             (numeric-key (plain-text->nums key))

             (reverse-key (reverse numeric-key))

             (ordered-map (lambda (f list)

                            (if (null? list)

                                list

                                (let ((val (f (car list))))

                                  (cons val (ordered-map f (cdr list))))))))

      (let ((rand-char (s (random ALPHA_SIZE)))) ;;pump through 1 random numbers between 0 and 26 and save it

        (nums->cipher-text (kd (cons rand-char (ordered-map s (plain-text->nums text))) reverse-key))))))



(define decrypt

  (lambda (text mono-key key)

    (letrec ((s (make-stream-decrypt (factory-mono-func (inverse-mono-key mono-key)) key))

             (numeric-key (plain-text->nums key))

             (reverse-key (reverse numeric-key))

             (ordered-map (lambda (f list)

                            (if (null? list)

                                list

                                (let ((val (f (car list))))

                                  (cons val (ordered-map f (cdr list))))))))

      (nums->cipher-text (cdr (ordered-map s (inverse-kd (plain-text->nums text) reverse-key)))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Following code by Scott Trimmer



;; Keyed decimation

(define kd

  (lambda (l k)

    (let ((n (length l)))

      (vector->list (kd-h l (subs k n) (make-vector n))))))



(define inverse-kd 

  (lambda (l k)

    (let ((n (length l)))

      (inverse-kd-h (list->vector l) (inverse-subs k n)))))



(define inverse-kd-h

  (lambda (vect indexes)

    (cond

     [(null? indexes) '()]

     [else (cons (vector-ref vect (- (car indexes) 1)) (inverse-kd-h vect (cdr indexes)))])))



(define kd-h

  (lambda (l indexes vect)

    (cond

     [(null? l) vect]

     [else (begin

	     (vector-set! vect (- (car indexes) 1) (car l))

	     (kd-h (cdr l) (cdr indexes) vect))])))







(define subs

  (lambda (k n)

    (get-subs (addpair (vector->list (insertion-subs k n))))))





(define insertion-subs

  (lambda (k n)

    ;;k list containing the key.   

    ;;n length of the message

    (insertion-subs-h 0 0 (list->vector k) (length k) 0 n (make-vector n))))



(define insertion-subs-h 

  (lambda (i kplace key klen mplace n vect)

    (let ((result (skipn-putx (vector-ref key kplace) mplace vect n (+ 1 i))))

      (cond

       [(eq?  (+ 1 i) n) vect]

       [else (insertion-subs-h (+ i 1) (modulo (+ kplace 1) klen) key  klen (car result) n (list->vector (cadr result)))]))))







(define skipn-putx

  (lambda (n place vect vlen x)

    (cond

      [(zero? n) (if (zero? (vector-ref vect place)) (begin

						       (vector-set! vect place x)

						       (cons place (list(vector->list vect))))

		     (skipn-putx n (modulo (+ 1 place) vlen) vect vlen x))]

      [(zero? (vector-ref vect place)) (skipn-putx (- n 1) (modulo (+ 1 place) vlen) vect vlen x)]

      [else (skipn-putx n (modulo (+ 1 place) vlen) vect vlen x)])))





(define upto

; returns a list of n elements of the numbers from 1 to n

  (lambda (n)

    (reverse (letrec ((loop (lambda (n)

			      (if (zero? n)

				  '()

				  (cons n (loop (sub1 n)))))))

	       (loop n)))))







(define addpair

  (lambda (l)

    (addpair-h l (upto (length l)))))



(define addpair-h

  (lambda (l1 l2)

    (cond

     [(null? l2) '()]

     [else (cons (cons (car l1) (list (car l2))) (addpair-h (cdr l1) (cdr l2)))])))







(define pair-sort

  (lambda (l)

    (sort (lambda (a b) (< (car a) (car b))) l)))



(define get-subs 

  (lambda (l)

    (cond

     [(null? l) '()]

     [else (cons (caar l) (get-subs (cdr l)))])))



(define get-inverse-subs

  (lambda (l)

    (cond

     [(null? l) '()]

     [else (cond (cadar l) (get-subs (cdr l)))])))





(define inverse-subs

  (lambda (k n)

    (get-subs  (addpair (vector->list (insertion-subs k n))))))





;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Following code by Jeff Walker



;;test for the example

(define example-string "g a short little example")

(define example-keyword "cat")

(define example-mono-key (list->vector (plain-text->nums "X K U S R T I J V A Z F C Y W P B H N L G E D O M Q")))



(define example-s-encrypt (make-stream-encrypt (factory-mono-func example-mono-key) example-keyword))

(define example-stream-encrypted (nums->cipher-text (map example-s-encrypt (plain-text->nums example-string))))