Last active
March 5, 2019 15:38
-
-
Save shirok/1858415 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; | |
;; Implementation of John Nash's enciphering-deciphering machine described in | |
;; https://www.nsa.gov/Portals/70/documents/news-features/declassified-documents/nash-letters/nash_letters1.pdf | |
;; | |
(use gauche.sequence) | |
(use gauche.generator) | |
(use srfi-1) | |
(use srfi-43) | |
(use srfi-60) | |
;; The 'key' of this machine is a configuration of Permuter-Reverser (P/R) | |
;; We have N positions in the P/R. You should provide two sets of | |
;; permutations P and reversal-bitmask R. | |
;; P is a permutation of (0 1 ... N-1). R is a list of N booleans | |
(define (make-permuter P0 P1 R0 R1) | |
(define regs (make-vector (length P0) #f)) | |
(^[in-bit] | |
(set! (~ regs 0) in-bit) | |
(permute! regs (uncycle-perm (if in-bit P1 P0))) | |
(vector-map! (^[i b] (xor (~ (if in-bit R1 R0) i) b)) regs) | |
(~ regs 0))) | |
(define (make-encipherer P0 P1 R0 R1) | |
(define P (make-permuter P0 P1 R0 R1)) | |
(define D #f) | |
(^[plaintext-input] | |
(^[] (glet1 in (plaintext-input) | |
(rlet1 r (xor in (P D)) | |
(set! D r)))))) | |
(define (make-decipherer P0 P1 R0 R1) | |
(define P (make-permuter P0 P1 R0 R1)) | |
(define D #f) | |
(^[ciphered-input] | |
(^[] (glet1 in (ciphered-input) | |
(rlet1 r (xor in (P D)) | |
(set! D in)))))) | |
(define (xor a b) (if (and a b) #f (or a b))) | |
;; Convert cycle notation of permutation (see TAOCP 1.3.3) into the | |
;; second-line of the two-line permutation. | |
(define (uncycle-perm p) | |
(map cdr (sort-by (map cons p (append (cdr p) p)) car))) | |
;; End of implementation | |
;; | |
;; The rest is convenient generator utilities | |
;; | |
(define (bytes->bools byte-gen) | |
(define c '()) | |
(^[] | |
(if (null? c) | |
(glet1 d (byte-gen) | |
(set! c (integer->list d 8)) | |
(pop! c)) | |
(pop! c)))) | |
(define (bools->bytes bool-gen) | |
(^[] (let1 bits (generator->list bool-gen 8) | |
(case (length bits) | |
[(0) (eof-object)] | |
[(8) (list->integer bits)] | |
[else (error "premature end of input stream")])))) | |
(define port->bools ($ bytes->bools $ port->byte-generator $)) | |
(define (string->bools s) (call-with-input-string s port->bools)) | |
(define write-bools | |
($ for-each (^b (write-byte b) (flush)) $ generator->lseq $ bools->bytes $)) | |
(define (bools->string bools) | |
(with-output-to-string (cut write-bools bools))) | |
;; Examples | |
#| | |
(define key '((1 3 6 2 4 0 5) | |
(2 1 5 0 3 6 4) | |
(#f #t #f #f #t #f #f) | |
(#t #t #t #f #f #t #t))) | |
(define E (apply make-encipherer key)) | |
(define D (apply make-decipherer key)) | |
($ bools->string $ D $ E $ string->bools "hi, there!") | |
($ write-bools $ D $ E $ port->bools (current-input-port)) | |
|# |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment