nash-cipher.scm

;;
;; 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))
|#