fork download
copy 
  1. ; elsie four
  2.  
  3. (define (drop n xs)
  4.   (let loop ((n n) (xs xs))
  5.     (if (or (zero? n) (null? xs)) xs
  6.       (loop (- n 1) (cdr xs)))))
  7.  
  8. (define (make-matrix rows columns . value)
  9.   (do ((m (make-vector rows)) (i 0 (+ i 1)))
  10.       ((= i rows) m)
  11.     (if (null? value)
  12.         (vector-set! m i (make-vector columns))
  13.         (vector-set! m i (make-vector columns (car value))))))
  14.  
  15. (define (matrix-ref m i j) (vector-ref (vector-ref m i) j))
  16.  
  17. (define (matrix-set! m i j x) (vector-set! (vector-ref m i) j x))
  18.  
  19. (define (string->ints str)
  20.   (define (c->i c)
  21.     (cond ((char=? c #\#) 0) ((char=? c #\_) 1)
  22.           ((char<=? #\2 c #\9) (- (char->integer c) (char->integer #\0)))
  23.           ((char<=? #\a c #\z) (- (char->integer c) (char->integer #\a) -10))
  24.           ((char<=? #\A c #\Z) (- (char->integer c) (char->integer #\A) -10))
  25.           (else (error 'string->ints "unrecognized character"))))
  26.   (map c->i (string->list str)))
  27.  
  28. (define (ints->string ints)
  29.   (define (i->c i)
  30.     (cond ((or (< i 0) (< 35 i)) (error 'ints->string "unrecognized character"))
  31.           ((= i 0) #\#) ((= i 1) #\_)
  32.           ((< i 10) (integer->char (+ (char->integer #\0) i)))
  33.           (else (integer->char (+ (char->integer #\A) i -10)))))
  34.   (list->string (map i->c ints)))
  35.  
  36. (define (initialize-state key)
  37.   (let ((xs (string->ints key)) (state (make-matrix 6 6)))
  38.     (do ((k 0 (+ k 1)) (xs xs (cdr xs))) ((null? xs) state)
  39.       (matrix-set! state (quotient k 6) (modulo k 6) (car xs)))))
  40.  
  41. (define (find s x)
  42.   (let loop ((k 0))
  43.     (let ((r (quotient k 6)) (c (modulo k 6)))
  44.       (if (= (matrix-ref s r c) x) (values r c)
  45.         (loop (+ k 1))))))
  46.  
  47. (define (advance-state state i j r c x y ct)
  48.   (let ((t (matrix-ref state r 5)))
  49.     (matrix-set! state r 5 (matrix-ref state r 4))
  50.     (matrix-set! state r 4 (matrix-ref state r 3))
  51.     (matrix-set! state r 3 (matrix-ref state r 2))
  52.     (matrix-set! state r 2 (matrix-ref state r 1))
  53.     (matrix-set! state r 1 (matrix-ref state r 0))
  54.     (matrix-set! state r 0 t))
  55.   (set! c (modulo (+ c 1) 6))
  56.   (when (= x r) (set! y (modulo (+ y 1) 6)))
  57.   (when (= i r) (set! j (modulo (+ j 1) 6)))
  58.   (let ((t (matrix-ref state 5 y)))
  59.     (matrix-set! state 5 y (matrix-ref state 4 y))
  60.     (matrix-set! state 4 y (matrix-ref state 3 y))
  61.     (matrix-set! state 3 y (matrix-ref state 2 y))
  62.     (matrix-set! state 2 y (matrix-ref state 1 y))
  63.     (matrix-set! state 1 y (matrix-ref state 0 y))
  64.     (matrix-set! state 0 y t))
  65.   (set! x (modulo (+ x 1) 6))
  66.   (when (= c y) (set! r (modulo (+ r 1) 6)))
  67.   (when (= j y) (set! i (modulo (+ i 1) 6)))
  68.   (set! i (modulo (+ i (quotient ct 6)) 6))
  69.   (set! j (modulo (+ j (modulo ct 6)) 6))
  70.   (values state i j r c x y))
  71.  
  72. (define (encrypt key nonce plaintext signature)
  73.   (let ((state (initialize-state key)) (i 0) (j 0))
  74.     (let loop ((ps (string->ints (string-append nonce plaintext signature)))
  75.                (state state) (i i) (j j) (cs (list)))
  76.       (if (null? ps)
  77.           (string-upcase (string-append nonce
  78.             (ints->string (drop (string-length nonce) (reverse cs)))))
  79.           (call-with-values
  80.             (lambda () (find state (car ps)))
  81.             (lambda (r c)
  82.               (let* ((x (modulo (+ r (quotient (matrix-ref state i j) 6)) 6))
  83.                      (y (modulo (+ c (modulo (matrix-ref state i j) 6)) 6))
  84.                      (ct (matrix-ref state x y)))
  85.                 (call-with-values
  86.                   (lambda () (advance-state state i j r c x y ct))
  87.                   (lambda (state i j r c x y)
  88.                     (loop (cdr ps) state i j (cons ct cs)))))))))))
  89.  
  90. (define (decrypt key nonce ciphertext)
  91.   (let ((state (initialize-state key)) (i 0) (j 0))
  92.     ; encrypt nonce (to set initial state for decryption)
  93.     (let loop ((ps (string->ints nonce)) (state state) (i i) (j j))
  94.       (when (pair? ps)
  95.         (call-with-values
  96.           (lambda () (find state (car ps)))
  97.           (lambda (r c)
  98.             (let* ((x (modulo (+ r (quotient (matrix-ref state i j) 6)) 6))
  99.                    (y (modulo (+ c (modulo (matrix-ref state i j) 6)) 6))
  100.                    (ct (matrix-ref state x y)))
  101.               (call-with-values
  102.                 (lambda () (advance-state state i j r c x y ct))
  103.                 (lambda (state i j r c x y)
  104.                   (loop (cdr ps) state i j))))))))
  105.     ; decrypt message text and signature
  106.     (let loop ((cs (string->ints ciphertext)) (state state) (i i) (j j) (ps (list)))
  107.       (if (null? cs)
  108.           (string-upcase (ints->string (reverse ps)))
  109.           (call-with-values
  110.             (lambda () (find state (car cs)))
  111.             (lambda (x y)
  112.               (let* ((r (modulo (- x (quotient (matrix-ref state i j) 6)) 6))
  113.                      (c (modulo (- y (modulo (matrix-ref state i j) 6)) 6))
  114.                      (pt (matrix-ref state r c)))
  115.                 (call-with-values
  116.                   (lambda () (advance-state state i j r c x y (car cs)))
  117.                   (lambda (state i j r c x y)
  118.                     (loop (cdr cs) state i j (cons pt ps)))))))))))
  119.  
  120. (define key "XV7YDQ#OPAJ_39RZUT8B45WCSGEHMIKNF26L")
  121. (define nonce "SOLWBF")
  122. (define plaintext "IM_ABOUT_TO_PUT_THE_HAMMER_DOWN")
  123. (define signature "#RUBBERDUCK")
  124.  
  125. (display (encrypt key nonce plaintext signature)) (newline)
  126. (display (decrypt key "SOLWBF" "I2ZQPILR2YQGPTLTRZX2_9FZLMBO3Y8_9PYSSX8NF2")) (newline)
Success #stdin #stdout 0.15s 9176KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
SOLWBFI2ZQPILR2YQGPTLTRZX2_9FZLMBO3Y8_9PYSSX8NF2
ZCIO5NFFSK8GHJ4LR3F8QNNVSK88VJH3JIEKIUQ8_6
https://ideone.com/DEfZJ8
language:
Scheme (guile 2.2.4)
created:
6 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!