Programming Praxis

We begin with a simple lexicon; plaintext is lower-case, ciphertext is upper-case:

(define lexicon '(("colonel" . "VENUS") ("captured" . "WAYLAND")
  ("vicksburg" . "ODOR") ("richmond" . "NEPTUNE") ("lincoln" .
  "ADAM") ("430pm" . "NELLY")))

Functions encode and decode translate the lexicon; both return the input word unchanged if it is not present:

(define (encode word)
  (let loop ((lexicon lexicon))
    (cond ((null? lexicon) (string-upcase word))
          ((string-ci=? (caar lexicon) word) (cdar lexicon))
          (else (loop (cdr lexicon))))))

(define (decode word)
  (let loop ((lexicon lexicon))
    (cond ((null? lexicon) (string-downcase word))
          ((string-ci=? (cdar lexicon) word) (caar lexicon))
          (else (loop (cdr lexicon))))))

We define two routes and several nulls:

(define routes '(("GUARD" 1 -2 5 -4 3) ("WILLOW" -3 4 -2 -6 1 -5)))

(define nulls '("THIS" "FILLS" "UP" "KISSING" "TURNING" "TIMES"
  "BELLY" "COMMISSIONER"))

We prepare the input by joining lines, removing punctuation, and splitting into a list of words:

(define (prepare strs)
  (string-split #\space
    (string-remove (string-join #\space strs) ",.:")))

Columns are read and written by get and put. A positive column number indicates that the column is read up, from bottom to top, and a negative column number indicates that the column is read down, from top to bottom:

(define (get grid col) ; positive => up from bottom to top
  (let ((start (if (positive? col) (- (matrix-rows grid) 1) 0))
        (delta (if (positive? col) -1 1))
        (end (if (positive? col) -1 (matrix-rows grid))))
    (let loop ((r start) (words (list)))
      (if (= r end) words
        (loop (+ r delta)
              (cons (matrix-ref grid r (- (abs col) 1)) words))))))

(define (put! grid col words)
  (let ((start (if (positive? col) (- (matrix-rows grid) 1) 0))
        (delta (if (positive? col) -1 1))
        (end (if (positive? col) -1 (matrix-rows grid))))
    (let loop ((r start) (words words))
      (unless (= r end)
        (matrix-set! grid r (- (abs col) 1) (decode (car words)))
        (loop (+ r delta) (cdr words))))))

We’re ready now to encipher text. The outer do loads words into the grid, the inner do pads the last line with nulls, and the named-let loop extracts the columns and forms the coded message, ready to be transmitted by courier or telegraph:

(define (encipher words route)
  (let* ((route (assoc route routes))
         (num-cols (length (cdr route)))
         (num-rows (ceiling (/ (length words) num-cols)))
         (grid (make-matrix num-rows num-cols "")))
    (do ((words words (cdr words)) (i 0 (+ i 1)))
        ((null? words)
          (do ((i i (+ i 1))) ((zero? (modulo i num-cols)))
            (matrix-set! grid (quotient i num-cols)
              (modulo i num-cols) (car nulls))
            (set! nulls (cdr nulls))))
      (matrix-set! grid (quotient i num-cols) (modulo i num-cols)
        (encode (car words))))
    (let loop ((cols (cdr route)) (nulls nulls)
               (message (list (car route))))
      (if (null? cols) (string-join #\space (reverse message))
        (loop (cdr cols) (cdr nulls)
          (cons (car nulls)
                (append (get grid (car cols)) message)))))))

Here’s the encipherment:

> (encipher (prepare '(
  "FOR COLONEL LUDLOW:"
  "RICHARDSON AND BROWN, CORRESPONDENTS OF THE TRIBUNE,"
  "CAPTURED AT VICKSBURG, ARE DETAINED AT RICHMOND."
  "PLEASE ASCERTAIN WHY THEY ARE DETAINED AND GET THEM"
  "OFF IF YOU CAN."
  "LINCOLN 4:30PM")))
"GUARD ADAM THEM THEY AT WAYLAND BROWN FOR KISSING VENUS CORRESPONDENTS AT NEPTUNE ARE OFF NELLY TURNING UP CAN GET WHY DETAINED TRIBUNE AND TIMES RICHARDSON THE ARE ASCERTAIN AND YOU FILLS BELLY THIS IF DETAINED PLEASE ODOR OF LUDLOW COMMISSIONER"

Deciphering is the reverse of enciphering. It’s also simpler, as we can simply ignore nulls. The first loop loads the grid, the second loop reads the message:

(define (decipher words)
  (let* ((route (assoc (car words) routes))
         (num-cols (length (cdr route)))
         (num-rows (ceiling (/ (- (length words) num-cols 1) num-cols)))
         (grid (make-matrix num-rows num-cols "")))
    (let loop ((cols (cdr route)) (words (cdr words)))
      (unless (null? cols)
        (put! grid (car cols) (take num-rows words))
        (loop (cdr cols) (drop (+ num-rows 1) words))))
    (let loop ((r 0) (c 0) (message (list)))
      (cond ((= r num-rows) (string-join #\space (reverse message)))
            ((= c num-cols) (loop (+ r 1) 0 message))
            (else (loop r (+ c 1) (cons (matrix-ref grid r c) message)))))))

And here’s the decipherment:

> (decipher (prepare '(
  "GUARD ADAM THEM THEY AT WAYLAND BROWN FOR KISSING VENUS"
  "CORRESPONDENTS AT NEPTUNE ARE OFF NELLY TURNING UP CAN"
  "GET WHY DETAINED TRIBUNE AND TIMES RICHARDSON THE ARE"
  "ASCERTAIN AND YOU FILLS BELLY THIS IF DETAINED PLEASE"
  "ODOR OF LUDLOW COMMISSIONER")))
"for colonel ludlow richardson and brown correspondents of the tribune captured at vicksburg are detained at richmond please ascertain why they are detained and get them off if you can lincoln 430pm this fills up"

We used string-remove from a recent exercise as well as several list, matrix and string functions from the Standard Prelude. You can run the program at http://programmingpraxis.codepad.org/LLNssAf7.

Pages: 1 2