Project:

Scheme, pasted on Mar 5:
 ```1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 ``` ```; union route cipher (define (take n xs) (let loop ((n n) (xs xs) (ys '())) (if (or (zero? n) (null? xs)) (reverse ys) (loop (- n 1) (cdr xs) (cons (car xs) ys))))) (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-rows x) (vector-length x)) (define (matrix-cols x) (vector-length (vector-ref x 0))) (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-downcase str) (list->string (map char-downcase (string->list str)))) (define (string-upcase str) (list->string (map char-upcase (string->list str)))) (define (string-split sep str) (define (f cs xs) (cons (list->string (reverse cs)) xs)) (let loop ((ss (string->list str)) (cs '()) (xs '())) (cond ((null? ss) (reverse (if (null? cs) xs (f cs xs)))) ((char=? (car ss) sep) (loop (cdr ss) '() (f cs xs))) (else (loop (cdr ss) (cons (car ss) cs) xs))))) (define (string-join sep ss) (define (f s ss) (string-append s (string sep) ss)) (define (join ss) (if (null? (cdr ss)) (car ss) (f (car ss) (join (cdr ss))))) (if (null? ss) "" (join ss))) (define (string-index c str) (let loop ((ss (string->list str)) (k 0)) (cond ((null? ss) #f) ((char=? (car ss) c) k) (else (loop (cdr ss) (+ k 1)))))) (define (string-remove str match) (let loop ((src 0) (dest 0)) (cond ((= (string-length str) src) (substring str 0 dest)) ((string-index (string-ref str src) match) (loop (+ src 1) dest)) (else (string-set! str dest (string-ref str src)) (loop (+ src 1) (+ dest 1)))))) (define lexicon '(("colonel" . "VENUS") ("captured" . "WAYLAND") ("vicksburg" . "ODOR") ("richmond" . "NEPTUNE") ("lincoln" . "ADAM") ("430pm" . "NELLY"))) (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)))))) (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")) (define (prepare strs) (string-split #\space (string-remove (string-join #\space strs) ",.:"))) (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)))))) (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))))))) (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))))))) (display (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")) (newline) (display (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")))) (newline) ```

Output:
 ```1 2 ``` ```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 ```