; elsie four
(define (drop n xs)
(let loop ((n n) (xs xs))
(if (or (zero? n) (null? xs)) xs
(loop (- n 1) (cdr xs)))))
(define (make-matrix rows columns . value)
(do ((m (make-vector rows)) (i 0 (+ i 1)))
((= i rows) m)
(if (null? value)
(vector-set! m i (make-vector columns))
(vector-set! m i (make-vector columns (car value))))))
(define (matrix-ref m i j) (vector-ref (vector-ref m i) j))
(define (matrix-set! m i j x) (vector-set! (vector-ref m i) j x))
(define (string->ints str)
(define (c->i c)
(cond ((char=? c #\#) 0) ((char=? c #\_) 1)
((char<=? #\2 c #\9) (- (char->integer c) (char->integer #\0)))
((char<=? #\a c #\z) (- (char->integer c) (char->integer #\a) -10))
((char<=? #\A c #\Z) (- (char->integer c) (char->integer #\A) -10))
(else (error 'string->ints "unrecognized character"))))
(map c->i (string->list str)))
(define (ints->string ints)
(define (i->c i)
(cond ((or (< i 0) (< 35 i)) (error 'ints->string "unrecognized character"))
((= i 0) #\#) ((= i 1) #\_)
((< i 10) (integer->char (+ (char->integer #\0) i)))
(else (integer->char (+ (char->integer #\A) i -10)))))
(list->string (map i->c ints)))
(define (initialize-state key)
(let ((xs (string->ints key)) (state (make-matrix 6 6)))
(do ((k 0 (+ k 1)) (xs xs (cdr xs))) ((null? xs) state)
(matrix-set! state (quotient k 6) (modulo k 6) (car xs)))))
(define (find s x)
(let loop ((k 0))
(let ((r (quotient k 6)) (c (modulo k 6)))
(if (= (matrix-ref s r c) x) (values r c)
(loop (+ k 1))))))
(define (advance-state state i j r c x y ct)
(let ((t (matrix-ref state r 5)))
(matrix-set! state r 5 (matrix-ref state r 4))
(matrix-set! state r 4 (matrix-ref state r 3))
(matrix-set! state r 3 (matrix-ref state r 2))
(matrix-set! state r 2 (matrix-ref state r 1))
(matrix-set! state r 1 (matrix-ref state r 0))
(matrix-set! state r 0 t))
(set! c (modulo (+ c 1) 6))
(when (= x r) (set! y (modulo (+ y 1) 6)))
(when (= i r) (set! j (modulo (+ j 1) 6)))
(let ((t (matrix-ref state 5 y)))
(matrix-set! state 5 y (matrix-ref state 4 y))
(matrix-set! state 4 y (matrix-ref state 3 y))
(matrix-set! state 3 y (matrix-ref state 2 y))
(matrix-set! state 2 y (matrix-ref state 1 y))
(matrix-set! state 1 y (matrix-ref state 0 y))
(matrix-set! state 0 y t))
(set! x (modulo (+ x 1) 6))
(when (= c y) (set! r (modulo (+ r 1) 6)))
(when (= j y) (set! i (modulo (+ i 1) 6)))
(set! i (modulo (+ i (quotient ct 6)) 6))
(set! j (modulo (+ j (modulo ct 6)) 6))
(values state i j r c x y))
(define (encrypt key nonce plaintext signature)
(let ((state (initialize-state key)) (i 0) (j 0))
(let loop ((ps (string->ints (string-append nonce plaintext signature)))
(state state) (i i) (j j) (cs (list)))
(if (null? ps)
(string-upcase (string-append nonce
(ints->string (drop (string-length nonce) (reverse cs)))))
(call-with-values
(lambda () (find state (car ps)))
(lambda (r c)
(let* ((x (modulo (+ r (quotient (matrix-ref state i j) 6)) 6))
(y (modulo (+ c (modulo (matrix-ref state i j) 6)) 6))
(ct (matrix-ref state x y)))
(call-with-values
(lambda () (advance-state state i j r c x y ct))
(lambda (state i j r c x y)
(loop (cdr ps) state i j (cons ct cs)))))))))))
(define (decrypt key nonce ciphertext)
(let ((state (initialize-state key)) (i 0) (j 0))
; encrypt nonce (to set initial state for decryption)
(let loop ((ps (string->ints nonce)) (state state) (i i) (j j))
(when (pair? ps)
(call-with-values
(lambda () (find state (car ps)))
(lambda (r c)
(let* ((x (modulo (+ r (quotient (matrix-ref state i j) 6)) 6))
(y (modulo (+ c (modulo (matrix-ref state i j) 6)) 6))
(ct (matrix-ref state x y)))
(call-with-values
(lambda () (advance-state state i j r c x y ct))
(lambda (state i j r c x y)
(loop (cdr ps) state i j))))))))
; decrypt message text and signature
(let loop ((cs (string->ints ciphertext)) (state state) (i i) (j j) (ps (list)))
(if (null? cs)
(string-upcase (ints->string (reverse ps)))
(call-with-values
(lambda () (find state (car cs)))
(lambda (x y)
(let* ((r (modulo (- x (quotient (matrix-ref state i j) 6)) 6))
(c (modulo (- y (modulo (matrix-ref state i j) 6)) 6))
(pt (matrix-ref state r c)))
(call-with-values
(lambda () (advance-state state i j r c x y (car cs)))
(lambda (state i j r c x y)
(loop (cdr cs) state i j (cons pt ps)))))))))))
(define key "XV7YDQ#OPAJ_39RZUT8B45WCSGEHMIKNF26L")
(define nonce "SOLWBF")
(define plaintext "IM_ABOUT_TO_PUT_THE_HAMMER_DOWN")
(define signature "#RUBBERDUCK")
(display (encrypt key nonce plaintext signature)) (newline)
(display (decrypt key "SOLWBF" "I2ZQPILR2YQGPTLTRZX2_9FZLMBO3Y8_9PYSSX8NF2")) (newline)