[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/LLNssAf7    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Mar 5:
; 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


Create a new paste based on this one


Comments: